├── .gitignore ├── LICENSE.txt ├── README.md ├── Setup.lhs ├── sirea-core.cabal ├── sirea-filesystem ├── LICENSE.txt ├── Setup.lhs ├── sirea-filesystem.cabal └── src │ └── Sirea │ ├── Filesystem.hs │ └── Filesystem │ ├── KeyedSched.hs │ ├── Linux.hs │ ├── LocalMirror.hs │ ├── Manager.hs │ ├── OSManager.hs │ ├── OSX.hs │ ├── Polling.hs │ ├── Windows.hs │ └── WorkerPool.hs ├── sirea-glfw ├── LICENSE.txt ├── Setup.lhs ├── sirea-glfw.cabal └── sources.txt ├── sirea-plugins ├── LICENSE.txt ├── Setup.lhs └── sirea-plugins.cabal ├── sources.txt ├── src └── Sirea │ ├── Activate.hs │ ├── AgentResource.hs │ ├── B.hs │ ├── BDeep.hs │ ├── Behavior.hs │ ├── Clock.hs │ ├── DemandMonitor.hs │ ├── Foreach.hs │ ├── Internal │ ├── B0.hs │ ├── B0Compile.hs │ ├── B0Dynamic.hs │ ├── B0Impl.hs │ ├── B0Type.hs │ ├── BCross.hs │ ├── CC.hs │ ├── Choke.hs │ ├── DemandMonitorData.hs │ ├── LTypes.hs │ ├── PTypes.hs │ ├── PulseSensor.hs │ ├── STypes.hs │ ├── SigType.hs │ ├── Thread.hs │ └── Tuning.hs │ ├── PCX.hs │ ├── Partition.hs │ ├── Prelude.hs │ ├── SRef.hs │ ├── Signal.hs │ ├── Time.hs │ ├── TimeStamp.hs │ ├── TimeTrigger.hs │ ├── Trans │ ├── Error.hs │ ├── Pure.hs │ ├── Reader.hs │ └── Static.hs │ ├── UnsafeIO.hs │ ├── UnsafeLink.hs │ └── Utility.hs └── tst ├── Clock.hs ├── Cyc.hs ├── Fibonacci.hs ├── Hello.hs ├── RotDyn.hs ├── TimeStamp.hs ├── TimeTrigger.hs ├── TstCross.hs ├── TstDeMon.hs └── TstPure.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | tmp/ 3 | *~ 4 | *.hi 5 | *.o 6 | *.prof 7 | src/FRP/Sirea/BdeepGen 8 | cabal-dev/ 9 | .shelly 10 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, David Barbour 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | 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 copyright 12 | notice, this list of conditions and the following disclaimer in 13 | the documentation and/or other materials provided with the 14 | distribution. 15 | 16 | * The names of contributors to this software may not be used to 17 | endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | 34 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /sirea-core.cabal: -------------------------------------------------------------------------------- 1 | Name: sirea-core 2 | Version: 0.1 3 | Synopsis: Simply Reactive! Declarative orchestration in Haskell with RDP. 4 | Category: Sirea, Reactivity 5 | Description: 6 | Reactive Demand Programming is an effectful, declarative, reactive 7 | model for orchestration of open systems. Sirea implements RDP in 8 | Haskell. This particular module is the `core` of Sirea, just the 9 | basic behaviors and implementation. Other packages will support 10 | specific domains or problems (UI, state, video, sound, etc.). 11 | 12 | RDP is similar to arrowized FRP, excepting how it manages effects 13 | and state. RDP behaviors can encapsulate access to resources and 14 | services, observing and influencing them through signals. State is 15 | modeled as an external service. (By comparison, FRP models state 16 | as an internal resource with event accumulators or integrals, but 17 | is purely functional. FRP does not encapsulate access to shared 18 | state or resources.) 19 | 20 | RDP is effectful, but not imperative. The constraints on effects 21 | ensure RDP achieves many reasoning, refactoring, and abstraction 22 | benefits of pure functional code. In particular, constraints for 23 | declarative expression are provided: commutative, idempotent, and 24 | associative expression; simple logical composition of effects as 25 | sets of concurrent demands. 26 | 27 | Arrowized composition of behaviors protects RDP properties. Sirea 28 | developers, however, must be disciplined when adding new effects 29 | modules: many hooks between RDP and Haskell IO are not RDP safe. 30 | 31 | For more information, see the github Readme and linked pages. 32 | 33 | Author: David Barbour 34 | Maintainer: dmbarbour@gmail.com 35 | Homepage: http://github.com/dmbarbour/Sirea 36 | 37 | Package-Url: 38 | Copyright: (c) 2013 by David Barbour 39 | License: BSD3 40 | license-file: LICENSE.txt 41 | Stability: experimental 42 | build-type: Simple 43 | cabal-version: >= 1.8 44 | 45 | Source-repository head 46 | type: git 47 | location: http://github.com/dmbarbour/Sirea.git 48 | 49 | Library 50 | hs-Source-Dirs: src 51 | Build-Depends: base (>= 4.5 && < 5) 52 | ,parallel (>= 3.0 && < 4) 53 | ,time (>= 1.4 && < 2) 54 | ,containers (>= 0.5 && < 2) 55 | 56 | Exposed-Modules: 57 | -- getting started 58 | Sirea.Prelude 59 | Sirea.Activate 60 | 61 | -- concepts 62 | Sirea.Behavior 63 | Sirea.Signal 64 | Sirea.Time 65 | Sirea.BDeep 66 | Sirea.Partition 67 | Sirea.PCX 68 | Sirea.B 69 | 70 | -- user support 71 | Sirea.Utility 72 | Sirea.UnsafeLink 73 | Sirea.UnsafeIO 74 | Sirea.DemandMonitor 75 | Sirea.AgentResource 76 | Sirea.Clock 77 | Sirea.TimeStamp 78 | Sirea.TimeTrigger 79 | Sirea.SRef 80 | 81 | -- transforms 82 | Sirea.Trans.Pure 83 | Sirea.Trans.Static 84 | Sirea.Trans.Error 85 | Sirea.Trans.Reader 86 | 87 | -- implementation details 88 | Sirea.Internal.CC 89 | Sirea.Internal.B0Type 90 | Sirea.Internal.B0Impl 91 | Sirea.Internal.B0Compile 92 | Sirea.Internal.B0Dynamic 93 | Sirea.Internal.B0 94 | Sirea.Internal.STypes 95 | Sirea.Internal.DemandMonitorData 96 | Sirea.Internal.Choke 97 | Sirea.Internal.SigType 98 | Sirea.Internal.LTypes 99 | Sirea.Internal.PTypes 100 | Sirea.Internal.BCross 101 | Sirea.Internal.Thread 102 | Sirea.Internal.PulseSensor 103 | Sirea.Internal.Tuning 104 | 105 | ghc-options: -Wall -fno-warn-orphans -auto-all 106 | 107 | 108 | -------------------------------------------------------------------------------- /sirea-filesystem/LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, David Barbour 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | 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 copyright 12 | notice, this list of conditions and the following disclaimer in 13 | the documentation and/or other materials provided with the 14 | distribution. 15 | 16 | * The names of contributors to this software may not be used to 17 | endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | 34 | -------------------------------------------------------------------------------- /sirea-filesystem/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /sirea-filesystem/sirea-filesystem.cabal: -------------------------------------------------------------------------------- 1 | Name: sirea-filesystem 2 | Version: 0.1 3 | cabal-Version: >= 1.8 4 | Synopsis: Simple view and manipulation of filesystem from Sirea. 5 | Category: Sirea 6 | Description: 7 | This package allows developers to observe a files in a reactive 8 | manner, and a few simplistic approaches to manipulation of files. 9 | The features here are very basic, most applicable to small files 10 | that can be loaded or saved all at once (as opposed to very large 11 | files, streaming files, etc.). 12 | 13 | Author: David Barbour 14 | Maintainer: dmbarbour@gmail.com 15 | Homepage: http://github.com/dmbarbour/Sirea 16 | Package-Url: 17 | Copyright: (c) 2013 by David Barbour 18 | License: BSD3 19 | license-file: LICENSE.txt 20 | Stability: experimental 21 | build-type: Simple 22 | 23 | Flag polling 24 | Description: use the polling implementation for testing or compatibility 25 | Default: False 26 | 27 | Library 28 | hs-Source-Dirs: src 29 | Build-Depends: base (>= 4.5 && < 5) 30 | ,sirea-core (>= 0.1) 31 | ,containers (>= 0.5) 32 | ,system-filepath (>= 0.4.7) 33 | ,system-fileio (>= 0.3.11) 34 | ,bytestring (>= 0.9) 35 | ,text (>= 0.11) 36 | 37 | Exposed-Modules: 38 | Sirea.Filesystem 39 | 40 | Other-Modules: 41 | Sirea.Filesystem.Polling 42 | Sirea.Filesystem.Manager 43 | Sirea.Filesystem.OSManager 44 | Sirea.Filesystem.WorkerPool 45 | Sirea.Filesystem.KeyedSched 46 | Sirea.Filesystem.LocalMirror 47 | 48 | Extensions: CPP 49 | ghc-options: -Wall -fno-warn-orphans 50 | 51 | if os(linux) && !flag(polling) 52 | CPP-Options: -DOS_Linux 53 | Other-Modules: Sirea.Filesystem.Linux 54 | Build-Depends: hinotify >= 0.3.5 55 | if os(windows) && !flag(polling) 56 | CPP-Options: -DOS_Windows 57 | Other-Modules: Sirea.Filesystem.Windows 58 | Build-Depends: Win32-notify >= 0.3 59 | if os(darwin) && !flag(polling) 60 | CPP-Options: -DOS_OSX 61 | Other-Modules: Sirea.Filesystem.OSX 62 | Build-Depends: hfsevents >= 0.1.3 63 | if flag(polling) 64 | CPP-Options: -DUSE_POLLING 65 | 66 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, 2 | FlexibleInstances, MultiParamTypeClasses, 3 | CPP 4 | #-} 5 | 6 | -- | Observe and influence the host filesystem through Sirea 7 | -- 8 | -- This module provides a simple file-at-a-time ontology for file 9 | -- observation and manipulation: 10 | -- 11 | -- * read a file as binary or text 12 | -- * list a directory 13 | -- * write or remove a file with binary or text 14 | -- 15 | -- These operations are continuous and reactive. When a file changes 16 | -- a observer of that file will update automatically. Continuous 17 | -- writes will only push updates when there is a change in the 18 | -- target file state. 19 | -- 20 | -- The current API is insufficient for operations on large files or 21 | -- streams. I may consider partial, region-based file manipulations 22 | -- in the future. 23 | -- 24 | -- NOTE: Compared to other state models, filesystem is inexpressive, 25 | -- difficult to speculate or retroactively correct, high latency, 26 | -- low security, weak robustness, no history. Use the filesystem for 27 | -- integration with external tools or users. For user interaction, 28 | -- files are persistent, declarative, and observed reactively. Files 29 | -- are a much closer fit for RDP than console or command-line IO. 30 | -- 31 | -- NOTE: Sirea.Filesystem does not make any effort to be savvy with 32 | -- regards to symbolic links. This will not change. Sirea uses the 33 | -- filesystem in a simplistic way 34 | -- 35 | module Sirea.Filesystem 36 | ( FS 37 | -- * Basic File Operations 38 | , breadFile 39 | , bwriteFile 40 | 41 | -- * Text Operations 42 | , breadFileText 43 | , bwriteFileText 44 | , breadFileString 45 | , bwriteFileString 46 | 47 | -- * Listing a directory 48 | , blistDirectory 49 | , FileDesc 50 | , fdIsFile 51 | , fdIsDir 52 | , fdModified 53 | , fdPath 54 | 55 | -- * Convenient Configuration Loading 56 | , bloadConfig 57 | , bloadConfigH 58 | , bloadConfigW 59 | 60 | -- * Quick access to directories. 61 | , bworkingDir 62 | , bhomeDir 63 | , bdesktopDir 64 | , bdocumentsDir 65 | ) where 66 | 67 | import Prelude hiding (FilePath) 68 | import Filesystem.Path (FilePath,()) 69 | import qualified Filesystem as FS 70 | import qualified Filesystem.Path as FS 71 | import Data.ByteString (ByteString) 72 | import Data.Text (Text) 73 | import qualified Data.Text as Text 74 | import qualified Data.Text.Encoding as Text 75 | import qualified Data.Text.Encoding.Error as Text 76 | import Data.IORef 77 | import Data.Unique 78 | import Data.Typeable 79 | import Data.Maybe (fromMaybe) 80 | import Control.Arrow (first, second) 81 | import Control.Monad (unless) 82 | import Control.Applicative 83 | 84 | import Sirea.Filesystem.LocalMirror 85 | 86 | import Sirea.Prelude 87 | import Sirea.UnsafeLink 88 | import Sirea.PCX 89 | import Sirea.Partition 90 | import Sirea.Signal 91 | 92 | import Debug.Trace (traceIO) 93 | 94 | -- | Sirea performs FileSystem operations in the FS partition. 95 | type FS = Pt Filesystem -- simple loop partition. 96 | data Filesystem deriving (Typeable) 97 | 98 | -- local-mirror resource 99 | newtype LM = LM LocalMirror deriving (Typeable) 100 | instance Resource (Pt Filesystem) LM where 101 | locateResource _ cp = 102 | getPSched cp >>= \ pd -> 103 | newLocalMirror pd >>= \ lm -> 104 | return (LM lm) 105 | 106 | -- | Read the current contents of a file. If the file does not exist 107 | -- or there are errors (e.g. lack of permission), Nothing will be 108 | -- returned. Read does not promise observation of every intermediate 109 | -- state in the filesystem, but wil reliably provide a recent state 110 | -- (assuming you aren't moving directories around and other corner 111 | -- cases). 112 | breadFile :: B (S FS FilePath) (S FS (Maybe ByteString)) 113 | breadFile = bfmap cleanFilePath >>> unsafeLinkBL mkFileReader 114 | 115 | -- any cleanup work I want to do on filepaths? 116 | cleanFilePath, cleanDirPath :: FilePath -> FilePath 117 | cleanFilePath = FS.collapse 118 | cleanDirPath = ( FS.empty) . FS.collapse 119 | 120 | mkFileReader :: PCX W -> LnkUp (Maybe ByteString) -> IO (LnkUp FilePath) 121 | mkFileReader cw ln = do 122 | cp <- getFSPCX cw 123 | pd <- getPSched cp 124 | k <- newUnique 125 | rf <- newIORef Nothing 126 | (LM lm) <- findInPCX cp 127 | return (readLink pd k rf lm ln) 128 | 129 | getFSPCX :: PCX W -> IO (PCX FS) 130 | getFSPCX = findInPCX 131 | 132 | -- read state 133 | type ReadSt = Maybe (Sig FilePath, StableT) 134 | 135 | readLink :: PSched -> Unique -> IORef ReadSt -> LocalMirror -> LnkUp (Maybe ByteString) -> LnkUp FilePath 136 | readLink pd k rf lm ln = error "TODO: read files" 137 | 138 | -- | Read a file as text. This simply maps a UTF-8 decode over the 139 | -- binary. Sequences that do not decode are replaced with U+FFFD, 140 | -- rather than throwing an exception. 141 | -- 142 | -- breadFileText = breadFile >>> bfmap (fmap toText) 143 | -- where toText = decodeUtf8With lenientDecode 144 | -- 145 | -- Sirea.Filesystem treats binary as the primary view to simplify 146 | -- interaction between readers and writers of different kinds. 147 | -- 148 | breadFileText :: B (S FS FilePath) (S FS (Maybe Text)) 149 | breadFileText = breadFile >>> bfmap (fmap toText) where 150 | toText = Text.decodeUtf8With Text.lenientDecode 151 | 152 | -- | Read a file as a string. This is not ideal for performance, but 153 | -- is convenient. Note that this translates to Text first. 154 | -- 155 | -- breadFileString = breadFileText >>> bfmap (fmap unpack) 156 | -- 157 | -- A relevant concern is that strings are not compact or efficient, 158 | -- and unless you're careful to process the string immediately with 159 | -- bfmap, it is possible the expanded version will be kept in cache. 160 | -- Text type is much better for efficient processing. 161 | breadFileString :: B (S FS FilePath) (S FS (Maybe String)) 162 | breadFileString = breadFile >>> bfmap (fmap toString) where 163 | toString = Text.unpack . Text.decodeUtf8With Text.lenientDecode 164 | 165 | -- | Write a file, or remove it. Intermediate directory structure is 166 | -- created if necessary. 167 | -- To remove a file, write Nothing. RDP's resource paradigm excludes 168 | -- notions of creation or destruction, but 'does-not-exist' can be 169 | -- understood as just another file state, distinct from empty file. 170 | -- 171 | -- Writes may be choked. I.e. if you demand a dozen states over one 172 | -- second, it may be that only one or two are actually written. Any 173 | -- final state will be written, barring disruption. After any crash, 174 | -- you'll be depending on the OS and underlying filesystem for the 175 | -- recovery. (Other state models for Sirea are more robust, using 176 | -- the acid-state package or similar. It may be useful to leverage a 177 | -- more robust state model to drive filesystem interactions.) 178 | -- 179 | -- Developers should avoid write-conflicts. It isn't difficult; just 180 | -- ensure by design that there is at most one writer for a given 181 | -- file. But if conflicts occur, Sirea favors keeping the lowest. In 182 | -- this case: lowest in lexicographic byte order. 183 | -- 184 | -- The response is simple boolean, with True being OK or success. A 185 | -- failure, whether due to permissions or write conflict, is False. 186 | -- 187 | bwriteFile :: B (S FS (FilePath, Maybe ByteString)) (S FS Bool) 188 | bwriteFile = bfmap (first cleanFilePath) >>> bvoid wf >>> vf where 189 | vf = (lf &&& bfmap snd) >>> bzipWith (==) -- verify by comparing read with write 190 | lf = bfmap fst >>> breadFile -- read the file 191 | wf = unsafeLinkB_ mkFileWriter -- try to write file (no direct return) 192 | 193 | -- it might be worth just hacking something out for now, i.e. that 194 | -- will not handle 195 | mkFileWriter :: PCX W -> IO (LnkUp (FilePath,Maybe ByteString)) 196 | mkFileWriter cw = do 197 | k <- newUnique 198 | cp <- getFSPCX cw 199 | (LM lm) <- findInPCX cp 200 | return (lnFileWriter k lm) 201 | 202 | lnFileWriter :: Unique -> LocalMirror -> 203 | 204 | -- | Write text to file as UTF-8 (via Binary) 205 | bwriteFileText :: B (S FS (FilePath, Maybe Text)) (S FS Bool) 206 | bwriteFileText = bfmap (second (fmap fromText)) >>> bwriteFile where 207 | fromText = Text.encodeUtf8 208 | 209 | -- | Write a string to file as UTF-8 (via Text) 210 | bwriteFileString :: B (S FS (FilePath, Maybe String)) (S FS Bool) 211 | bwriteFileString = bfmap (second (fmap fromString)) >>> bwriteFile where 212 | fromString = Text.encodeUtf8 . Text.pack 213 | 214 | -- | List contents of a directory, including relevant metadata. 215 | blistDirectory :: B (S FS FilePath) (S FS [FileDesc]) 216 | blistDirectory = bfmap cleanDirPath >>> unsafeLinkBL mkDirReader 217 | 218 | mkDirReader :: PCX W -> LnkUp [FileDesc] -> IO (LnkUp FilePath) 219 | mkDirReader = error "TODO: load directory info" 220 | 221 | -- | For user interaction, it would often be convenient to create or 222 | -- load a configuration file with default text. This is a utility 223 | -- operation to support that common pattern. If the file does not 224 | -- exist, it will be created in the filesystem with the given text. 225 | -- In case of read error, the given text is returned. 226 | bloadConfig :: IO FilePath -> Text -> B (S FS ()) (S FS Text) 227 | bloadConfig getPath txt = lc where 228 | lc = unsafeLinkBL ini >>> breadFileText >>> bfmap (fromMaybe txt) 229 | ini cw ln = do 230 | fp <- cleanFilePath <$> getPath 231 | cp <- getFSPCX cw 232 | (LM lm) <- findInPCX cp 233 | lmSchedWork lm fp (initFile fp) 234 | return (ln_sfmap (s_const fp) ln) 235 | initFile fp = 236 | FS.isFile fp >>= \ bFile -> 237 | unless bFile $ 238 | FS.createTree (FS.directory fp) >> 239 | FS.writeTextFile fp txt 240 | 241 | -- load config relative to a directory. 242 | bloadConfigRel :: IO FilePath -> FilePath -> Text -> B (S FS ()) (S FS Text) 243 | bloadConfigRel getDirPath name txt = bloadConfig iodir txt where 244 | iodir = if FS.absolute name then return name else 245 | ( name) <$> getDirPath 246 | 247 | -- | bloadConfigH, bloadConfigW - load configs relative to home or 248 | -- working directory, respectively. If absolute path is given, it is 249 | -- used as an absolute path. 250 | bloadConfigH, bloadConfigW :: FilePath -> Text -> B (S FS ()) (S FS Text) 251 | bloadConfigH = bloadConfigRel FS.getHomeDirectory 252 | bloadConfigW = bloadConfigRel FS.getWorkingDirectory 253 | 254 | -- | Access ambient information about user directories or working 255 | -- directory. Note: these values are assumed constant during one 256 | -- run of the Haskell process. Developers should not manipulate the 257 | -- working directory after starting a Sirea application. 258 | -- 259 | -- bworkingDir : directory from which app was started; "." path 260 | -- bhomeDir : user's home directory 261 | -- bdesktopDir : user directory, based on OS 262 | -- bdocumentsDir : user directory, based on OS 263 | -- 264 | -- Application data should instead be kept using sirea-state. Files 265 | -- are not well suited to RDP, but are useful for user interactions, 266 | -- so only user directories are provided here (to subtly discourage 267 | -- keeping app data in files). 268 | -- 269 | bworkingDir, bhomeDir, bdesktopDir, bdocumentsDir :: B (S p ()) (S p FilePath) 270 | bworkingDir = bioconst FS.getWorkingDirectory 271 | bhomeDir = bioconst FS.getHomeDirectory 272 | bdesktopDir = bioconst FS.getDesktopDirectory 273 | bdocumentsDir = bioconst FS.getDocumentsDirectory 274 | 275 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/KeyedSched.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- Keyed scheduler, exists to ensure that no more than one task is 4 | -- active per 'key' at a time. In this context, a key is likely a 5 | -- filepath or directory path. Wraps another scheduler. 6 | module Sirea.Filesystem.KeyedSched 7 | ( newKeyedSched 8 | ) where 9 | 10 | import Control.Monad (join, void) 11 | import Control.Exception (finally, assert) 12 | import Data.IORef 13 | import qualified Data.Map as M 14 | 15 | data KSched k = KS !(IORef (WorkMap k)) !Sched 16 | type Sched = Work -> IO () 17 | type WorkMap k = M.Map k [Work] 18 | type Work = IO () 19 | 20 | newKeyedSched :: (Ord k) => (Work -> IO ()) -> IO (k -> Work -> IO ()) 21 | newKeyedSched sched = 22 | newIORef M.empty >>= \ rf -> 23 | let ks = KS rf sched in 24 | return (addKeyedWork ks) 25 | 26 | addKeyedWork :: (Ord k) => KSched k -> k -> Work -> IO () 27 | addKeyedWork ks@(KS rf _) k w = join $ atomicModifyIORef rf addw where 28 | addw m0 = addw' m0 (M.lookup k m0) 29 | addw' m0 Nothing = (M.insert k [] m0, initKeyedWork ks k w) 30 | addw' m0 (Just ws) = (M.insert k (ws ++ [w]) m0, return ()) 31 | 32 | returnKey :: (Ord k) => KSched k -> k -> IO () 33 | returnKey ks@(KS rf _) k = join $ atomicModifyIORef rf rel where 34 | rel m0 = rel' m0 (M.lookup k m0) 35 | rel' m0 Nothing = assert False $ (m0,return ()) -- illegal state 36 | rel' m0 (Just []) = (M.delete k m0, return ()) -- key released 37 | rel' m0 (Just (w:ws)) = (M.insert k ws m0, initKeyedWork ks k w) 38 | 39 | initKeyedWork :: (Ord k) => KSched k -> k -> Work -> IO () 40 | initKeyedWork ks@(KS _ sched) k w = sched (w `finally` returnKey ks k) 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/Linux.hs: -------------------------------------------------------------------------------- 1 | 2 | -- File notifications using Linux's hinotify. 3 | -- 4 | -- The current design is that the inotify subsystem is created when 5 | -- we have at least one active watch. From there, we add or remove 6 | -- watches to match the current watch-list. Since all watches have 7 | -- the same callback event, there is no trouble with updating the 8 | -- watch action on a directory. 9 | module Sirea.Filesystem.Linux 10 | ( newManager 11 | ) where 12 | 13 | import Prelude hiding (FilePath) 14 | import Filesystem.Path (FilePath, ()) 15 | import Filesystem.Path.CurrentOS (encodeString, decodeString) 16 | import qualified Filesystem as FS 17 | import Control.Concurrent.MVar 18 | import Data.Maybe (catMaybes) 19 | import qualified Data.Map as M 20 | import qualified System.INotify as INo 21 | import qualified System.IO.Error as IOE 22 | import qualified Control.Exception as E 23 | 24 | import Sirea.Time 25 | import Sirea.Filesystem.Manager 26 | 27 | import Debug.Trace (traceIO) 28 | 29 | 30 | type WatchMap = M.Map FilePath INo.WatchDescriptor 31 | type WatchData = Maybe (INo.INotify, WatchMap) 32 | data L = L 33 | { l_watch :: !(MVar WatchData) 34 | , l_action :: !EventsHandler 35 | } 36 | 37 | newManager :: MkManager 38 | newManager eh = 39 | newMVar Nothing >>= \ rfW -> 40 | let lm = (L rfW eh) in 41 | return (Manager (setWatch lm)) 42 | 43 | setWatch :: L -> [FilePath] -> IO () 44 | setWatch l wl = modifyMVar_ (l_watch l) setw where 45 | setw Nothing = 46 | if (null wl) then return Nothing else do 47 | ino <- INo.initINotify 48 | setw' ino M.empty 49 | setw (Just (ino,m0)) = 50 | if (null wl) 51 | then INo.killINotify ino >> return Nothing 52 | else setw' ino m0 53 | setw' ino m0 = do 54 | wds <- mapM (addw ino m0) wl 55 | let m' = M.fromList $ catMaybes wds 56 | mapM_ remw (M.toList (m0 `M.difference` m')) 57 | return (Just (ino,m')) 58 | addw ino m0 dir = addw' ino dir (M.lookup dir m0) `E.catch` addE dir 59 | addE dir ioe = printError dir ioe >> return Nothing 60 | addw' _ dir (Just wd) = return $ Just (dir,wd) 61 | addw' ino dir Nothing = 62 | inoAddWatch ino dir (l_action l) >>= \ wd -> 63 | return (Just (dir,wd)) 64 | remw (d,wd) = INo.removeWatch wd `E.catch` printError d 65 | 66 | printError :: FilePath -> IOE.IOError -> IO () 67 | printError d ioe = traceIO ("error @ " ++ show d ++ ": " ++ show ioe) 68 | 69 | inoAddWatch :: INo.INotify -> FilePath -> EventsHandler -> IO INo.WatchDescriptor 70 | inoAddWatch ino dir action = INo.addWatch ino v dir' (catchIOE . eh) where 71 | v = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.CloseWrite] 72 | dir' = encodeString dir 73 | catchIOE op = op `E.catch` printError dir 74 | eh (INo.Created bd n) = touched bd n 75 | eh (INo.Closed bd (Just n) True) = touched bd n 76 | eh (INo.MovedOut bd n _) = removed bd n 77 | eh (INo.MovedIn bd n _) = touched bd n 78 | eh (INo.Deleted bd n) = removed bd n 79 | eh _ = action [] 80 | touched bDir n = 81 | let name = decodeString n in 82 | let fullPath = dir name in 83 | FS.getModified fullPath >>= \ tMod -> 84 | let ev = Event True dir name bDir (fromUTC tMod) in 85 | action [ev] 86 | removed bDir n = 87 | let name = decodeString n in 88 | getTime >>= \ tNow -> 89 | let tDel = tNow `subtractTime` 0.01 in 90 | let ev = Event False dir name bDir tDel in 91 | action [ev] 92 | 93 | 94 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/LocalMirror.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | The Filesystem module will keep a local mirror of the actively 3 | -- observed or manipulated portions of the Filesystem. Most of this 4 | -- is done in IO, but asynchronously and with tight control over 5 | -- resource consumption (using workers and mt-safe operations). 6 | -- 7 | -- LocalMirror 'belongs' to a particular partition, for which PSched 8 | -- is provided. 9 | -- 10 | -- Readers must re-subscribe after every notification (i.e. each 11 | -- update is one-time only). 12 | -- 13 | module Sirea.Filesystem.LocalMirror 14 | ( FileDesc(..), FType(..) 15 | , fdIsFile, fdIsDir, fdModified, fdPath 16 | , LocalMirror 17 | , newLocalMirror 18 | , lmSchedWork 19 | ) where 20 | 21 | import Prelude hiding (FilePath, catch) 22 | import Filesystem.Path.CurrentOS(FilePath) 23 | import qualified Filesystem as FS 24 | import qualified Filesystem.Path.CurrentOS as FS 25 | import Sirea.Time (T) 26 | import qualified Data.Map.Strict as M 27 | import qualified Data.ByteString as B 28 | import Data.Unique 29 | import Data.IORef 30 | import Control.Exception (catch, SomeException) 31 | import Control.Monad.Fix (mfix) 32 | 33 | import Sirea.Partition 34 | import Sirea.Filesystem.Manager 35 | import Sirea.Filesystem.OSManager 36 | import Sirea.Filesystem.WorkerPool 37 | import Sirea.Filesystem.KeyedSched 38 | 39 | import Debug.Trace 40 | 41 | -- TUNING 42 | -- How many files shall we allow to read or write concurrently? 43 | numFileLoaders :: Int 44 | numFileLoaders = 6 45 | 46 | -- | A FileDesc contains a simple description of a file. 47 | data FileDesc = FD !FType !FilePath !T deriving (Show,Ord,Eq) 48 | data FType = Dir | File deriving (Show,Ord, Eq) 49 | 50 | fdIsFile, fdIsDir :: FileDesc -> Bool 51 | fdModified :: FileDesc -> T 52 | fdPath :: FileDesc -> FilePath 53 | 54 | fdIsFile (FD ty _ _) = isFile ty 55 | fdIsDir (FD ty _ _) = isDir ty 56 | fdModified (FD _ _ t) = t 57 | fdPath (FD _ p _) = p 58 | 59 | isDir, isFile :: FType -> Bool 60 | isDir Dir = True 61 | isDir _ = False 62 | isFile File = True 63 | isFile _ = False 64 | 65 | -- local mirror has a few schedulers and some mutable data 66 | data LocalMirror = LocalMirror 67 | { lm_wsched :: !(FilePath -> IO () -> IO ()) 68 | , lm_psched :: !PSched 69 | , lm_fsm :: !Manager 70 | , lm_data :: !(IORef LMD) 71 | } 72 | 73 | -- LMD models the filesystem as flat (no hierarchy) 74 | -- there is a pool of active write signals 75 | -- 76 | data LMD = LMD 77 | 78 | lmdZero :: LMD 79 | lmdZero = LMD 80 | 81 | newLocalMirror :: PSched -> IO LocalMirror 82 | newLocalMirror pd = mfix $ \ lm -> 83 | newIORef lmdZero >>= \ rf -> 84 | newManager (eventsHandler lm) >>= \ fsm -> 85 | newWorkerPool numFileLoaders >>= \ wp -> 86 | newKeyedSched wp >>= \ ks -> 87 | return (LocalMirror ks pd fsm rf) 88 | 89 | eventsHandler :: LocalMirror -> [Event] -> IO () 90 | eventsHandler _ [] = return () 91 | eventsHandler lm es = 92 | onNextStep (lm_psched lm) $ 93 | mapM_ (eventHandler lm) es 94 | 95 | eventHandler :: LocalMirror -> Event -> IO () 96 | eventHandler _ e = traceIO ("TODO: handle event " ++ show e) 97 | 98 | -- Schedule work regarding a particular file. Will serialize with 99 | -- other work on the same file. Will be performed when a worker is 100 | -- available. 101 | lmSchedWork :: LocalMirror -> FilePath -> IO () -> IO () 102 | lmSchedWork lm fp = lm_wsched lm fp . catchAll fp 103 | 104 | catchAll :: FilePath -> IO () -> IO () 105 | catchAll fp op = op `catch` reportE fp 106 | 107 | reportE :: FilePath -> SomeException -> IO () 108 | reportE fp e = traceIO ("sirea-filesystem error: " ++ show fp ++ " - " ++ show e) 109 | 110 | 111 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/Manager.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Definition of Manager type used internally by Sirea.Filesystem, 3 | -- and of the Event type handled by update actions. Implemented for 4 | -- each OS. 5 | -- 6 | -- The manager tracks a set of directories, reporting updates to a 7 | -- single action passed to the manager upon construction. 8 | module Sirea.Filesystem.Manager 9 | ( Event(..) 10 | , evDirPath, evFileName, evFullPath, evTime 11 | , isExistsEvent, isDirectoryEvent 12 | , EventsHandler 13 | , Manager(..) 14 | , MkManager 15 | ) where 16 | 17 | import Prelude hiding (FilePath) 18 | import Filesystem.Path (FilePath,()) 19 | import Filesystem.Path.CurrentOS() 20 | import Sirea.Time (T) 21 | 22 | -- | An event reports either the existence or non-existence of a file. 23 | -- The time may be a best estimate. 24 | data Event = Event !Exists !Dir !Name !IsDir !T deriving (Show,Eq,Ord) 25 | type Dir = FilePath -- path of file in directory 26 | type Name = FilePath -- name of file in directory 27 | type Exists = Bool -- does the named file still exist? 28 | type IsDir = Bool -- does Name refer to a child directory 29 | 30 | evDirPath, evFileName, evFullPath :: Event -> FilePath 31 | evDirPath (Event _ dp _ _ _) = dp 32 | evFileName (Event _ _ fn _ _) = fn 33 | evFullPath (Event _ dp fn _ _) = dp fn 34 | evTime :: Event -> T 35 | evTime (Event _ _ _ _ tm) = tm 36 | isExistsEvent, isDirectoryEvent :: Event -> Bool 37 | isExistsEvent (Event bExists _ _ _ _) = bExists 38 | isDirectoryEvent (Event _ _ _ bDir _) = bDir 39 | 40 | -- Handle an event, or a bulk set of events. This operation must be 41 | -- mt-safe and non-blocking. Bulk sends will only be used if not 42 | -- inconvenient for the particular Manager. The caller must be 43 | -- robust to hearing about files it already knows; the action is 44 | -- assumed idempotent for events. 45 | type EventsHandler = [Event] -> IO () 46 | 47 | -- Manager: track a time-varying set of directories. 48 | -- 49 | -- setWatchList: specify active watch list. FilePaths that are in 50 | -- previous 'setWatchList' actions but not in the current one 51 | -- should be removed. 52 | -- 53 | -- The Manager is responsible for its own use of internal resources 54 | -- or threads. Sirea.Filesystem will only create one manager per 55 | -- Filesystem partition, and currently has only one such partition. 56 | -- 57 | -- The given watch list should use directory paths in canonical form. 58 | -- 59 | data Manager = Manager 60 | { setWatchList :: [Dir] -> IO () 61 | } 62 | 63 | -- Create a manager. One handler is used for all events for all 64 | -- active watches. Each manager module should export: 65 | -- newManger :: MkManager 66 | type MkManager = EventsHandler -> IO Manager 67 | 68 | 69 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/OSManager.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | -- Select the OS-specific manager. 5 | module Sirea.Filesystem.OSManager (newManager) where 6 | 7 | #if defined(USE_POLLING) 8 | import Sirea.Filesystem.Manager 9 | import Sirea.Filesystem.Polling 10 | #elif defined(OS_Linux) 11 | import Sirea.Filesystem.Linux 12 | #elif defined(OS_Windows) 13 | import Sirea.Filesystem.Windows 14 | #elif defined(OS_OSX) 15 | import Sirea.Filesystem.OSX 16 | #endif 17 | 18 | #if defined(USE_POLLING) 19 | dtPoll :: DT 20 | dtPoll = 3.0 -- seconds 21 | 22 | newManager :: MkManager 23 | newManager = newPollingManager dtPoll 24 | #endif 25 | 26 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/OSX.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Sirea.Filesyste.OSX 4 | ( newManager 5 | ) where 6 | 7 | import qualified System.OSX.FSEvents as FSE 8 | import Sirea.Filesystem.Polling 9 | import Debug.Trace 10 | 11 | newManager :: MkManager 12 | newManager eh = 13 | traceIO ("TODO: OSX notifications (using hfsevents).") >> 14 | newPollingManager eh 15 | 16 | 17 | {- Code from FSNotify for guidance 18 | 19 | -- 20 | -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org 21 | -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org 22 | -- 23 | module System.FSNotify.OSX 24 | ( newSession 25 | ) where 26 | 27 | -- NOTE: this version of FSNotify has recently had a major overhaul. 28 | -- If someone with access to OSX > 10.6 could cajole the following 29 | -- code into working order, it'd be appreciated. Following is a best 30 | -- effort without compiling it. 31 | 32 | 33 | import Prelude hiding (FilePath, catch) 34 | import System.FSNotify.Polling (newPollingSession) -- fallback 35 | import Control.Concurrent.Chan 36 | import Control.Concurrent.MVar 37 | import Control.Monad hiding (void) 38 | import Data.Bits 39 | import Data.IORef (atomicModifyIORef, readIORef) 40 | import Data.Map (Map) 41 | import Data.Time.Clock (UTCTime, getCurrentTime) 42 | import Data.Word 43 | -- import Debug.Trace (trace) 44 | import Filesystem (isFile) 45 | import Filesystem.Path hiding (concat) 46 | import System.FSNotify.Listener 47 | import System.FSNotify.Path (fp, canonicalizeDirPath) 48 | import System.FSNotify.Types 49 | import qualified Data.Map as Map 50 | 51 | 52 | -- TODO: We really should use something other than FilePath as a key to allow 53 | -- for more than one listener per FilePath. 54 | type WatchMap = Map FilePath FSE.EventStream 55 | data OSXManager = OSXManager (MVar WatchMap) 56 | 57 | newSession :: IO Session 58 | newSession = FSE.fileLevelEventsSupported >>= mkSession where 59 | mkSession True = fmap osxSession newManager 60 | mkSession False = newPollingSession 61 | 62 | newManager :: IO OSXManager 63 | newManager = fmap OSXManager (newMVar Map.empty) 64 | 65 | osxSession :: OSXManager -> Session 66 | osxSession mgr = Session (kill mgr) (clear mgr) (start mgr) 67 | 68 | kill :: OSXManager -> IO () 69 | kill (OSXManager wm) = modifyMVar killAll >>= mapM_ FSE.eventStreamDestroy where 70 | killAll m0 = return (Map.empty, Map.elems m0) 71 | 72 | clear :: OSXManager -> FilePath -> IO () 73 | clear (OSXManager wm) dir = join $ modifyMVar killDir where 74 | killDir m0 = return $ killDir' m0 (Map.lookup dir m0) 75 | killDir' m0 Nothing = (m0,return()) 76 | killDir' m0 (Just es) = (Map.delete dir m0, FSE.eventStreamDestroy es) 77 | 78 | 79 | start :: OSXManager -> FilePath -> Action -> IO () 80 | start (OSXManager wm) dir action = body where 81 | handler = handleFSEEvents dir action 82 | body = do 83 | es <- FSE.eventStreamCreate [fp dir] 0.0 True False True handler 84 | join $ modifyMVar wm (add es) 85 | add es m0 = return $ add' es m0 (Map.lookup dir m0) 86 | add' es m0 Nothing = (Map.insert dir es m0, return ()) 87 | add' es m0 (Just es0) = (Map.insert dir es m0, FSE.eventStreamDestroy es0) 88 | 89 | nil :: Word64 90 | nil = 0x00 91 | 92 | -- OS X reports the absolute (canonical) path without a trailing slash. Add 93 | -- the trailing slash when the path refers to a directory 94 | canonicalEventPath :: FSE.Event -> FilePath 95 | canonicalEventPath event = 96 | if flags .&. dirFlag /= nil then path empty else path 97 | where 98 | flags = FSE.eventFlags event 99 | dirFlag = FSE.eventFlagItemIsDir 100 | path = fp $ FSE.eventPath event 101 | 102 | fsnEvents :: UTCTime -> FSE.Event -> IO [Event] 103 | fsnEvents timestamp fseEvent = liftM concat . sequence $ map (\f -> f fseEvent) (eventFunctions timestamp) 104 | where 105 | eventFunctions :: UTCTime -> [FSE.Event -> IO [Event]] 106 | eventFunctions t = [addedFn t, modifFn t, removFn t, renamFn t] 107 | addedFn t e = if hasFlag e FSE.eventFlagItemCreated then return [Added (path e) t] else return [] 108 | modifFn t e = if (hasFlag e FSE.eventFlagItemModified 109 | || hasFlag e FSE.eventFlagItemInodeMetaMod) then return [Modified (path e) t] else return [] 110 | removFn t e = if hasFlag e FSE.eventFlagItemRemoved then return [Removed (path e) t] else return [] 111 | renamFn t e = if hasFlag e FSE.eventFlagItemRenamed then 112 | isFile (path e) >>= \exists -> if exists then return [Added (path e) t] else return [Removed (path e) t] 113 | else 114 | return [] 115 | path = canonicalEventPath 116 | hasFlag event flag = FSE.eventFlags event .&. flag /= 0 117 | 118 | -- Separate logic is needed for non-recursive events in OSX because the 119 | -- hfsevents package doesn't support non-recursive event reporting. 120 | 121 | handleNonRecursiveFSEEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO () 122 | -- handleNonRecursiveFSEEvent _ _ dirPath _ fseEvent | trace ("OSX: handleNonRecursiveFSEEvent " ++ show dirPath ++ " " ++ show fseEvent) False = undefined 123 | handleNonRecursiveFSEEvent actPred chan dirPath dbp fseEvent = do 124 | currentTime <- getCurrentTime 125 | events <- fsnEvents currentTime fseEvent 126 | handleNonRecursiveEvents actPred chan dirPath dbp events 127 | handleNonRecursiveEvents :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO () 128 | -- handleNonRecursiveEvents actPred _ dirPath _ (event:_ ) | trace ( "OSX: handleNonRecursiveEvents " 129 | -- ++ show dirPath ++ " " ++ show event 130 | -- ++ "\n " ++ fp (directory dirPath) 131 | -- ++ "\n " ++ fp (directory (eventPath event)) 132 | -- ++ "\n " ++ show (actPred event)) False = undefined 133 | handleNonRecursiveEvents actPred chan dirPath dbp (event:events) 134 | | directory dirPath == directory (eventPath event) && actPred event = do 135 | case dbp of 136 | (Just (DebounceData epsilon ior)) -> do 137 | lastEvent <- readIORef ior 138 | when (not $ debounce epsilon lastEvent event) (writeChan chan event) 139 | atomicModifyIORef ior (\_ -> (event, ())) 140 | Nothing -> writeChan chan event 141 | handleNonRecursiveEvents actPred chan dirPath dbp events 142 | | otherwise = handleNonRecursiveEvents actPred chan dirPath dbp events 143 | handleNonRecursiveEvents _ _ _ _ [] = void 144 | 145 | handleFSEEvent :: EventChannel -> FSE.Event -> IO () 146 | -- handleFSEEvent _ _ _ fseEvent | trace ("OSX: handleFSEEvent " ++ show fseEvent) False = undefined 147 | handleFSEEvent chan fseEvent = do 148 | currentTime <- getCurrentTime 149 | events <- fsnEvents currentTime fseEvent 150 | handleEvents chan events 151 | 152 | 153 | -} 154 | 155 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/Polling.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Polling implementation. This isn't intended to be super efficient, 3 | -- just a decent fallback in case there is no OS implementation. 4 | -- 5 | -- To alleviate race conditions, files younger than ten seconds are 6 | -- reported with existence events for any new subscription. 7 | -- 8 | module Sirea.Filesystem.Polling 9 | ( newPollingManager 10 | ) where 11 | 12 | import Prelude hiding (FilePath) 13 | import Control.Monad (void,unless) 14 | import Control.Concurrent 15 | import Data.IORef 16 | import Data.Maybe (catMaybes) 17 | import Data.List (sort) 18 | import Data.Function (on) 19 | import qualified Data.Map as M 20 | import qualified Filesystem.Path as FS 21 | import qualified Filesystem as FS 22 | import qualified Control.Exception as E 23 | import qualified System.IO.Error as IOE 24 | import Sirea.Filesystem.Manager 25 | import Sirea.Time 26 | import Debug.Trace (traceIO) 27 | 28 | data P = P 29 | { p_dtPoll :: !DT 30 | , p_sigup :: !(MVar ()) -- signal watchlist update. 31 | , p_watch :: !(IORef [FilePath]) 32 | , p_action :: !(EventsHandler) 33 | } 34 | 35 | type FilePath = FS.FilePath 36 | 37 | -- Polling keeps a simple memory for comparing results. The Event is 38 | -- used as a file records, since it's close enough to what I need. A 39 | -- 'Nothing' value indicates this is the first time we're polling a 40 | -- path, so no changes are reported for that initial effort. 41 | -- 42 | -- The lists in PMem will have been sorted by contents. 43 | type PMem = M.Map FilePath (Maybe [FileRec]) 44 | 45 | -- for a FileRec, the FilePath is local to directory 46 | data FileRec = FileRec 47 | { fr_path :: !FilePath 48 | , fr_isdir :: !Bool 49 | , fr_mod :: {-# UNPACK #-} !T 50 | } 51 | 52 | -- if a file is younger than dtYoung, we'll report it for any new 53 | -- subscriptions as a new file, i.e. to make sure the subscriber 54 | -- doesn't miss it due to a race condition. 55 | dtYoung :: DT 56 | dtYoung = 15 -- seconds 57 | 58 | newPollingManager :: DT -> MkManager 59 | newPollingManager dtPoll eh = 60 | newEmptyMVar >>= \ w -> 61 | newIORef [] >>= \ rfL -> 62 | let p = P dtPoll w rfL eh in 63 | forkIO (pollInit p) >> 64 | return (Manager (setWatch p)) 65 | 66 | -- setWatch simply records the watchlist then signals the change. 67 | -- This will be handled the next time the poll thread tests for 68 | -- the signal. Does not block. 69 | setWatch :: P -> [FilePath] -> IO () 70 | setWatch (P _ u w _) wl = void $ writeIORef w wl >> tryPutMVar u () 71 | 72 | -- pollInit is the state when we don't have any active watches. 73 | pollInit :: P -> IO () 74 | pollInit p = takeMVar (p_sigup p) >> updateWatchList p M.empty 75 | 76 | -- if we receive a watch-list update, we'll need to adjust the 77 | -- memory and polling effort. 78 | updateWatchList :: P -> PMem -> IO () 79 | updateWatchList p m = 80 | readIORef (p_watch p) >>= \ wl -> 81 | if (null wl) then pollInit p else 82 | pollCycle p (pollMemTransfer wl m) 83 | 84 | -- pollMemTransfer will keep information on paths in the original 85 | -- map after a change in the watchlist. 86 | pollMemTransfer :: [FilePath] -> PMem -> PMem 87 | pollMemTransfer wl mOrig = foldl addPath M.empty wl where 88 | addPath m dir = 89 | case M.lookup dir mOrig of 90 | Nothing -> M.insert dir Nothing m 91 | Just x -> M.insert dir x m 92 | 93 | -- the main polling cycle 94 | pollCycle :: P -> PMem -> IO () 95 | pollCycle p oldMem = 96 | tryTakeMVar (p_sigup p) >>= \ mbu -> 97 | case mbu of 98 | Just () -> updateWatchList p oldMem 99 | Nothing -> do 100 | tNow <- getTime 101 | newMem <- mainPollingAction tNow p oldMem 102 | threadDelay (dtToUsec (p_dtPoll p)) 103 | pollCycle p newMem 104 | 105 | dtToUsec :: DT -> Int 106 | dtToUsec = fromIntegral . (`div` 1000) . dtToNanos 107 | 108 | expectedError :: IOE.IOError -> Bool 109 | expectedError ioe = 110 | IOE.isDoesNotExistError ioe || 111 | IOE.isPermissionError ioe 112 | 113 | printError :: FilePath -> IOE.IOError -> IO () 114 | printError d ioe = traceIO ("error @ " ++ show d ++ ": " ++ show ioe) 115 | 116 | -- obtain a FilePath-sorted list of file records. 117 | listDirectory :: FilePath -> IO [FileRec] 118 | listDirectory dir = happyPath `E.catch` sadPath where 119 | sadPath ioe = 120 | unless (expectedError ioe) (printError dir ioe) >> 121 | return [] 122 | happyPath = do 123 | dl <- sort `fmap` FS.listDirectory dir 124 | dlRec <- mapM pathToRecord dl 125 | return (catMaybes dlRec) 126 | 127 | -- pathToRecord will return Nothing if there is any exception. 128 | -- The input path should already be canonicalized. 129 | pathToRecord :: FilePath -> IO (Maybe FileRec) 130 | pathToRecord path = happyPath `E.catch` sadPath where 131 | sadPath ioe = printError path ioe >> return Nothing 132 | happyPath = do 133 | bDir <- FS.isDirectory path 134 | tMod <- fromUTC `fmap` FS.getModified path 135 | return $ Just (FileRec path bDir tMod) 136 | 137 | mainPollingAction :: T -> P -> PMem -> IO PMem 138 | mainPollingAction tNow p = M.traverseWithKey dirAction where 139 | dirAction dir Nothing = do 140 | dlExists <- listDirectory dir 141 | let tY = tNow `subtractTime` dtYoung 142 | let dly = filter ((> tY) . fr_mod) dlExists 143 | p_action p (map (existsEvent dir) dly) 144 | return (Just dlExists) 145 | dirAction dir (Just dlOld) = do 146 | dlNew <- listDirectory dir 147 | let evs = diffEvents dir tNow dlOld dlNew 148 | p_action p evs 149 | return (Just dlNew) 150 | 151 | -- diff of two sorted lists. The given tNow is necessary for file 152 | -- removal events. 153 | diffEvents :: FilePath -> T -> [FileRec] -> [FileRec] -> [Event] 154 | diffEvents d _ [] newFiles = map (existsEvent d) newFiles 155 | diffEvents d t oldFiles [] = map (removedEvent d t) oldFiles 156 | diffEvents d t os@(o:os') ns@(n:ns') = 157 | case (compare `on` fr_path) o n of 158 | LT -> removedEvent d t o : diffEvents d t os' ns 159 | GT -> existsEvent d n : diffEvents d t os ns' 160 | EQ -> let rest = diffEvents d t os' ns' in 161 | if (fr_isdir o /= fr_isdir n) 162 | then let tRem = fr_mod n `subtractTime` 0.01 in 163 | removedEvent d tRem o : existsEvent d n : rest 164 | else if (fr_mod n /= fr_mod o) 165 | then existsEvent d n : rest 166 | else rest 167 | 168 | existsEvent :: FilePath -> FileRec -> Event 169 | existsEvent dir (FileRec p d tMod) = Event True dir p d tMod 170 | 171 | removedEvent :: FilePath -> T -> FileRec -> Event 172 | removedEvent dir tNow (FileRec p d _) = Event False dir p d tNow 173 | 174 | 175 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/Windows.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Sirea.Filesyste.Windows 4 | ( newManager 5 | ) where 6 | 7 | import qualified System.Win32.Notify as W 8 | import Sirea.Filesystem.Polling 9 | import Debug.Trace 10 | 11 | newManager :: MkManager 12 | newManager eh = 13 | traceIO ("TODO: Windows notifications using Win32-notify.") >> 14 | newPollingManager eh 15 | 16 | 17 | 18 | {- code from FSNotify for guidance 19 | 20 | 21 | import Prelude hiding (FilePath) 22 | 23 | import Control.Concurrent.Chan 24 | import Control.Monad (when) 25 | import Data.IORef (atomicModifyIORef, readIORef) 26 | import Data.Time (getCurrentTime, UTCTime) 27 | import System.FSNotify.Listener 28 | import System.FSNotify.Path (fp, canonicalizeDirPath) 29 | import System.FSNotify.Types 30 | import qualified System.Win32.Notify as WNo 31 | 32 | type NativeManager = WNo.WatchManager 33 | 34 | -- TODO: Need to ensure we use properly canonalized paths as 35 | -- event paths. In Linux this required passing the base dir to 36 | -- handle[native]Event. 37 | 38 | void :: IO () 39 | void = return () 40 | 41 | -- Win32-notify has (temporarily?) dropped support for Renamed events. 42 | fsnEvent :: UTCTime -> WNo.Event -> Maybe Event 43 | fsnEvent timestamp (WNo.Created False name) = Just $ Added (fp name) timestamp 44 | fsnEvent timestamp (WNo.Modified False name) = Just $ Modified (fp name) timestamp 45 | fsnEvent timestamp (WNo.Deleted False name) = Just $ Removed (fp name) timestamp 46 | fsnEvent _ _ = Nothing 47 | {- 48 | fsnEvents timestamp (WNo.Renamed False (Just oldName) newName) = [Removed (fp oldName) timestamp, Added (fp newName) timestamp] 49 | fsnEvents timestamp (WNo.Renamed False Nothing newName) = [Added (fp newName) timestamp] 50 | -} 51 | 52 | handleWNoEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () 53 | handleWNoEvent actPred chan dbp inoEvent = do 54 | currentTime <- getCurrentTime 55 | let maybeEvent = fsnEvent currentTime inoEvent 56 | case maybeEvent of 57 | Just evt -> handleEvent actPred chan dbp evt 58 | Nothing -> void 59 | 60 | instance FileListener WNo.WatchManager where 61 | initSession = fmap Just WNo.initWatchManager 62 | killSession = WNo.killWatchManager 63 | listen db watchManager path actPred chan = do 64 | WNo.watchDirectory watchManager (fp path') False varieties (handler actPred chan dbp) 65 | listenRecursive db watchManager path actPred chan = do 66 | WNo.watchDirectory watchManager (fp path') True varieties (handler actPred chan dbp) 67 | 68 | handler :: ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () 69 | handler = handleWNoEvent 70 | 71 | varieties :: [WNo.EventVariety] 72 | varieties = [WNo.Create, WNo.Delete, WNo.Move, WNo.Modify] 73 | 74 | -} 75 | 76 | 77 | -------------------------------------------------------------------------------- /sirea-filesystem/src/Sirea/Filesystem/WorkerPool.hs: -------------------------------------------------------------------------------- 1 | 2 | -- A pool of worker threads. Effectively a semaphore. But in this 3 | -- case, new threads will spin up when necessary and self-destruct 4 | -- when they run out of work. (Threads are cheap in Haskell.) The 5 | -- main reason to limit concurrent work is to control resources, 6 | -- e.g. number of open file descriptors and the amount of memory in 7 | -- use but inaccessible due to only partial completion. 8 | -- 9 | -- Intended for short-lived work, e.g. to read or write one file. 10 | -- The IO operations should have their own way of calling home when 11 | -- a result is needed. Workers will silently kill exceptions, but 12 | -- the IO ops should catch them first (now asserted for debugging). 13 | -- 14 | module Sirea.Filesystem.WorkerPool 15 | ( newWorkerPool 16 | ) where 17 | 18 | import Data.IORef 19 | import Control.Monad (join, void, liftM) 20 | import Control.Exception (assert, try, SomeException) 21 | import Control.Concurrent (forkIO) 22 | 23 | type WPD = Either Int [IO ()] 24 | type WPool = IORef WPD 25 | 26 | newWorkerPool :: Int -> IO (IO () -> IO ()) 27 | newWorkerPool n = assert (n > 0) $ liftM addWork $ newIORef (Left n) 28 | 29 | addWork :: WPool -> IO () -> IO () 30 | addWork wp op = join $ atomicModifyIORef wp addw where 31 | addw (Left 0) = (Right [op],return ()) 32 | addw (Left n) = assert (n > 0) $ (Left (pred n), forkWorker wp op) 33 | addw (Right ops) = (Right opsop, return ()) where 34 | opsop = ops ++ [op] 35 | 36 | forkWorker :: WPool -> IO () -> IO () 37 | forkWorker wp op = void $ forkIO $ workerLoop wp op 38 | 39 | workerLoop :: WPool -> IO () -> IO () 40 | workerLoop wp op = (try op >>= assertNoE) >> doMoreWork wp 41 | 42 | assertNoE :: Either SomeException a -> IO () 43 | assertNoE (Left _) = assert False $ return () 44 | assertNoE _ = return () 45 | 46 | doMoreWork :: WPool -> IO () 47 | doMoreWork wp = join $ atomicModifyIORef wp takew where 48 | takew (Left n) = (Left (succ n), return ()) 49 | takew (Right []) = error "invalid state for worker pool" 50 | takew (Right (op:[])) = (Left 0, workerLoop wp op) 51 | takew (Right (op:ops)) = (Right ops, workerLoop wp op) 52 | 53 | -------------------------------------------------------------------------------- /sirea-glfw/LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, David Barbour 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | 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 copyright 12 | notice, this list of conditions and the following disclaimer in 13 | the documentation and/or other materials provided with the 14 | distribution. 15 | 16 | * The names of contributors to this software may not be used to 17 | endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | 34 | -------------------------------------------------------------------------------- /sirea-glfw/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /sirea-glfw/sirea-glfw.cabal: -------------------------------------------------------------------------------- 1 | Name: sirea-glfw 2 | Version: 0.1 3 | Cabal-Version: >= 1.2 4 | Synopsis: Joystick, Keyboard, Mouse, and an OpenGL window in Sirea 5 | Category: Sirea 6 | Description: 7 | This project is a simple adapter to GLFW in Sirea. GLFW provides 8 | simplified, portable access to joystick, keyboard, mouse, and an 9 | OpenGL window. It is comparable to SDL, but without sound support. 10 | 11 | All resources in GLFW are provided in a single partition, which is 12 | bound to an OS level thread. One thread for many responsibilities 13 | is not to my preference, but GLFW conveniently achieves useful and 14 | portable behaviors in a hurry. Sirea-glfw will use only the GLFW 15 | features demanded of it, e.g. it will not query for joystic state 16 | if nobody is listening, and will raise a window only when there is 17 | something to render. 18 | 19 | Keyboard, Joystick, and Mouse adapt quite easily to the RDP model. 20 | Keys are modeled statefully, but are observed using GLFW callbacks 21 | to ensure every intermediate keystate is represented, and that all 22 | overlapping keypresses are properly observable as overlapping. 23 | 24 | A weakness of GLFW is that it does not report the OS event times, 25 | thus Sirea must make best-effort estimates, which adds error and 26 | variance to user-input latency. Also, GLFW does supports only 27 | one mouse and one keyboard, and has no support for identifying 28 | joysticks by name or type (which hinders configuration). Also, a 29 | GLFW window must be open to access mouse or keyboard. (There are 30 | many things to dislike about GLFW. The more I learn, the more I 31 | think about switching to SDL.) 32 | 33 | GLFW is designed with an assumption that there is only one render 34 | function. RDP is designed to be extensible and pluggable; there 35 | may be many concurrent render demands, with new demands introduced 36 | dynamically. To accommodate the needs of both RDP and GLFW, the 37 | sirea-glfw module asks for a little extra metadata to support 38 | rendering to subwindows, layout and layering. 39 | 40 | Essentially, sirea-glfw models a simplistic window manager within 41 | a GLFW window. It is reasonably expressive, leverages stable logic 42 | to minimize disruptions in the face of changing constraints. But 43 | developers who desire precise control should take the expedient 44 | route of ensuring they are the only behavior writing to that GLFW 45 | resource, and shift any cooperation to a pre-render model. 46 | 47 | Author: David Barbour 48 | Maintainer: dmbarbour@gmail.com 49 | Homepage: http://github.com/dmbarbour/Sirea 50 | Package-Url: 51 | Copyright: (c) 2012 by David Barbour 52 | License: BSD3 53 | Stability: experimental 54 | build-type: Simple 55 | 56 | Library 57 | hs-Source-Dirs: src 58 | Build-Depends: base (>=4.5), 59 | sirea-core (>=0.1) 60 | 61 | Exposed-Modules: 62 | Sirea.GLFW 63 | Sirea.GLFW.Joystick 64 | Sirea.GLFW.Mouse 65 | Sirea.GLFW.Keyboard 66 | Sirea.GLFW.Render 67 | 68 | ghc-options: -threaded -Wall -fno-warn-orphans 69 | 70 | 71 | -------------------------------------------------------------------------------- /sirea-glfw/sources.txt: -------------------------------------------------------------------------------- 1 | ./ 2 | ../ 3 | 4 | -------------------------------------------------------------------------------- /sirea-plugins/LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, David Barbour 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | 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 copyright 12 | notice, this list of conditions and the following disclaimer in 13 | the documentation and/or other materials provided with the 14 | distribution. 15 | 16 | * The names of contributors to this software may not be used to 17 | endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | 34 | -------------------------------------------------------------------------------- /sirea-plugins/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /sirea-plugins/sirea-plugins.cabal: -------------------------------------------------------------------------------- 1 | Name: sirea-plugins 2 | Version: 0.1 3 | Cabal-Version: >= 1.2 4 | Synopsis: Runtime Plugins and Live Programming for Sirea 5 | Category: Sirea 6 | Description: 7 | Plugins offer a flexible approach to dependencies and extension 8 | of applications. Live programming is possible by compiling code 9 | into a plugin at runtime, in accordance with changes to code. 10 | 11 | Sirea plugins may serve as both dependencies and extensions, and 12 | may depend on other plugins. Plugins are linked by type, via 13 | Data.Typeable. 14 | 15 | Sirea requires that plugins link at most one value of each type. 16 | Developers are guaranteed that identical types result in shared 17 | resources. Two plugins conflict if they export matching types. 18 | Alternatives for a type serve as fallbacks to achieve robust and 19 | adaptive applications. Extensions must also have a unique type, 20 | though theirs is just a thin wrapper to declare a role. 21 | 22 | Support for "soft" constraints (preferences) is also planned, so 23 | that developers can have more control without sacrificing robust 24 | degradation and adaptiveness of having fallback plugins. Linking 25 | will essentially be a weighted satisfiability computation. 26 | 27 | Applications can be built entirely of extensions. 28 | 29 | A related package, sirea-app, uses sirea-plugins to provide just 30 | that model for development. Each extension is a main behavior - 31 | concurrent, reactive, operating on shared dependencies. This is 32 | effectively a multi-agent model (extension per agent). 33 | 34 | Plugins may be registered via an RDP behavior at runtime, which 35 | supports dynamic resource discovery and adaptation patterns. 36 | 37 | Author: David Barbour 38 | Maintainer: dmbarbour@gmail.com 39 | Homepage: http://github.com/dmbarbour/Sirea 40 | Package-Url: 41 | Copyright: (c) 2012 by David Barbour 42 | License: BSD3 43 | Stability: experimental 44 | build-type: Simple 45 | 46 | Library 47 | hs-Source-Dirs: src 48 | Build-Depends: base>4.5 49 | 50 | Exposed-Modules: 51 | Sirea.Plugins 52 | 53 | ghc-options: -threaded -Wall -fno-warn-orphans 54 | 55 | 56 | -------------------------------------------------------------------------------- /sources.txt: -------------------------------------------------------------------------------- 1 | ./ 2 | 3 | -------------------------------------------------------------------------------- /src/Sirea/AgentResource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-} 2 | 3 | -- | AgentResource supports developers of FFI resource adapters in 4 | -- expressing some logic with RDP code. Essentially, it allows 5 | -- partition resources to be wrapped with singleton RDP behaviors. 6 | -- Behaviors are described by AgentBehavior class, then instantiated 7 | -- with the invokeAgent behavior. Concurrent demands may result in 8 | -- the agent being kept around longer. 9 | -- 10 | -- Safe RDP behaviors are idempotent. Use of AgentResource will not 11 | -- impact them, except for performance (eliminating redundant 12 | -- computations). But AgentResource primarily benefits unsafe RDP 13 | -- behaviors - e.g. it doesn't matter that your unsafeOnUpdate 14 | -- behaviors are not idempotent if strictly invoked as singletons. 15 | -- 16 | -- Communication with the invoked behaviors is performed through 17 | -- demand monitors or shared state (blackboard metaphors). 18 | -- 19 | module Sirea.AgentResource 20 | ( unsafeInvokeAgent 21 | , AgentBehavior(..) 22 | ) where 23 | 24 | import Control.Applicative 25 | import Control.Monad (when) 26 | import Control.Exception (assert) 27 | import Control.Monad.Fix (mfix) 28 | 29 | import Data.IORef 30 | import Data.Typeable 31 | import Data.Maybe 32 | import Data.Function (fix) 33 | 34 | import Sirea.Signal 35 | import Sirea.Behavior 36 | import Sirea.B 37 | import Sirea.PCX 38 | import Sirea.Partition 39 | import Sirea.UnsafeLink 40 | import Sirea.Time 41 | 42 | import Sirea.Internal.B0Compile (compileB0) 43 | import Sirea.Internal.DemandMonitorData 44 | import Sirea.Internal.B0Impl (wrapLnEqShift) 45 | import Sirea.Internal.LTypes 46 | 47 | --import Debug.Trace 48 | 49 | -- | The RDP behaviors of AgentResources are defined in a typeclass. 50 | -- The behaviors are indexed by partition and a `duty` type. Use the 51 | -- `invokeAgent` behavior to compile and install a unique instance 52 | -- of the AgentResource (even if invoked many times concurrently). 53 | -- While an agentBehaviorSpec will start in a particular partition, 54 | -- it is free to cross into related partitions to perform its duty. 55 | -- 56 | -- Recommendation is to keep the `duty` types hidden, and export the 57 | -- behaviors that use invokeAgent directly. This ensures uniqueness. 58 | -- 59 | -- Caution: AgentBehavior should not do anything that might invoke 60 | -- itself or it will start keeping itself alive, out of control. 61 | -- 62 | class (Partition p, Typeable duty) => AgentBehavior p duty where 63 | -- | This should be instantiated as: agentBehaviorSpec _ = ... 64 | -- The `duty` parameter is undefined, used only for typeful 65 | -- construction. 66 | agentBehaviorSpec :: duty -> B (S p ()) S1 67 | 68 | -- AgentResource ensures single instance for invokeAgent. A record 69 | -- of the signal is maintained here in order to ensure an old agent 70 | -- is kept in memory until it is no longer necessary. 71 | -- 72 | -- NOTE: AgentResource is modeled as a global resource, since the 73 | -- agentBehavior may cross into multiple partitions. However, the 74 | -- AgentResource is still identified by its starting partition. 75 | data AR p duty = AR 76 | { ar_daggr :: !(DemandAggr () ()) -- track invocations 77 | , ar_make :: !(IO (LnkUp ())) -- how to instantiate agent 78 | , ar_data :: !(IORef ARD) -- state and instance tracking 79 | } deriving (Typeable) 80 | 81 | data ARD = ARD 82 | { ard_signal :: !(Sig ()) -- record of signal 83 | , ard_link :: !(Maybe (LnkUp ())) -- current instance 84 | } 85 | 86 | ardZero :: ARD 87 | ardZero = ARD s_never Nothing 88 | 89 | instance (AgentBehavior p duty) => Resource W (AR p duty) where 90 | locateResource _ = newAR 91 | 92 | newAR :: (AgentBehavior p duty) => PCX W -> IO (AR p duty) 93 | newAR cw = mfix $ \ ar -> -- fix cyclic dependencies 94 | getPCX ar cw >>= \ cp -> 95 | newIORef ardZero >>= \ rf -> 96 | getPSched cp >>= \ pd -> 97 | let b0 = unwrapB (getABS ar) cw in -- behavior 98 | let cc0 = CC { cc_getSched = return pd, cc_newRef = newRefIO } in 99 | let lc0 = LC { lc_dtCurr = 0, lc_dtGoal = 0, lc_cc = cc0 } in 100 | let lcaps = LnkSig (LCX lc0) in 101 | let make = ln_lnkup <$> snd (compileB0 b0 lcaps LnkDead) in 102 | let lu = LnkUp (touchAR ar) (updateAR ar) (idleAR ar) (cycleAR ar) in 103 | wrapLnEqShift (==) lu >>= \ luEq -> 104 | newDemandAggr pd luEq sigActive >>= \ da -> 105 | return (AR da make rf) 106 | 107 | -- functions getABS, getDuty, getPCX mostly for type wrangling 108 | getABS :: (AgentBehavior p duty) => AR p duty -> B (S p ()) S1 109 | getABS = agentBehaviorSpec . getDuty 110 | 111 | getDuty :: AR p duty -> duty 112 | getDuty _ = undefined 113 | 114 | getPCX :: (Partition p) => AR p duty -> PCX W -> IO (PCX p) 115 | getPCX _ = findInPCX 116 | 117 | -- simple merge of activity signals 118 | sigActive :: [Sig a] -> Sig () 119 | sigActive [] = s_never 120 | sigActive (s:ss) = s_const () $ foldl (<|>) s ss 121 | 122 | -- Touch on AgentResource will forward touch to the agent. 123 | -- It also instantiates the agent, if needed. 124 | touchAR :: AR p duty -> IO () 125 | touchAR ar = getARLink ar >>= \ lu -> ln_touch lu 126 | 127 | -- load or create agent link 128 | getARLink :: AR p duty -> IO (LnkUp ()) 129 | getARLink ar = 130 | readIORef (ar_data ar) >>= \ ard -> 131 | case ard_link ard of 132 | Just lu -> 133 | return lu 134 | Nothing -> 135 | --traceIO ("new Agent") >> 136 | ar_make ar >>= \ lu -> 137 | let ard' = ard { ard_link = Just lu } in 138 | writeIORef (ar_data ar) ard' >> 139 | return lu 140 | 141 | -- test the agent for cyclic dependencies; creates the agent if it 142 | -- is necessary to do so. 143 | cycleAR :: AR p duty -> CycleSet -> IO () 144 | cycleAR ar ns = getARLink ar >>= \ lu -> ln_cycle lu ns 145 | 146 | idleAR :: AR p duty -> StableT -> IO () 147 | idleAR ar tS = 148 | readIORef (ar_data ar) >>= \ ard -> 149 | assert ((not . isNothing . ard_link) ard) $ 150 | let lu = fromMaybe ln_zero (ard_link ard) in 151 | let s' = s_trim (ard_signal ard) (inStableT tS) in 152 | let bDone = s_term s' (inStableT tS) in 153 | let ard' = ard { ard_signal = s' } in 154 | ard' `seq` writeIORef (ar_data ar) ard' >> 155 | --traceIO ("agent idle tS = " ++ show tS) >> 156 | ln_idle lu tS >> 157 | when bDone (clearAR ar) 158 | 159 | updateAR :: AR p duty -> StableT -> T -> Sig () -> IO () 160 | updateAR ar tS tU su = 161 | readIORef (ar_data ar) >>= \ ard -> 162 | assert ((not . isNothing . ard_link) ard) $ 163 | let lu = fromMaybe ln_zero (ard_link ard) in 164 | let s1 = s_switch (ard_signal ard) tU su in 165 | let s' = s_trim s1 (inStableT tS) in 166 | let bDone = s_term s' (inStableT tS) in 167 | let ard' = ard { ard_signal = s' } in 168 | ard' `seq` writeIORef (ar_data ar) ard' >> 169 | --let ssu = sigToList s1 (tU `subtractTime` 1) (tU `addTime` 60) in 170 | --traceIO ("agent update tS = " ++ show tS ++ " tU = " ++ show tU ++ show ssu) >> 171 | ln_update lu tS tU su >> 172 | when bDone (clearAR ar) 173 | 174 | -- clearAR is called whenever an agent stabilizes on inactivity. It 175 | -- immediately removes the link from memory and resets the agent to 176 | -- its initial state. If the agent is needed again, it is rebuilt. 177 | -- In practice, this is conservative because the agent isn't cleared 178 | -- if the signal is ambiguous about future activity. 179 | clearAR :: AR p duty -> IO () 180 | clearAR ar = 181 | --traceIO ("clearAR") >> 182 | writeIORef (ar_data ar) ardZero 183 | 184 | -- | `invokeAgent` will install a unique instance of agent behavior 185 | -- (one for each unique partition-duty pair). This behavior is built 186 | -- and installed on demand, then uninstalled and GC'd when there is 187 | -- no active demand, potentially many times in the Haskell process. 188 | -- 189 | -- Logically, use of `invokeAgent` should have the same results as 190 | -- many concurrent instances due to RDP's idempotence. However, the 191 | -- unique installation may be much more efficient and will simplify 192 | -- safe use of non-idempotent adapters (e.g. unsafeOnUpdate). 193 | -- 194 | -- Caution: invokeAgent is unsafe because cyclic invocations could 195 | -- ultimately cause the agent to keep itself alive. This is usually 196 | -- not a problem, since developers have pretty good control over 197 | -- agent behavior. But if an agent uses dynamic behavior or invokes 198 | -- another agent, one must be cautious. 199 | -- 200 | unsafeInvokeAgent :: (AgentBehavior p duty) => duty -> B (S p ()) (S p ()) 201 | unsafeInvokeAgent duty = fix $ \ b -> invokeDutyAR (getAR duty b) 202 | 203 | invokeDutyAR :: (PCX W -> IO (AR p duty)) -> B (S p ()) (S p ()) 204 | invokeDutyAR findAR = bvoid (unsafeLinkWB_ lnInvoke) where 205 | lnInvoke cw = findAR cw >>= newDemandLnk . ar_daggr 206 | 207 | getAR :: (AgentBehavior p duty) 208 | => duty -> B (S p ()) (S p ()) -> PCX W -> IO (AR p duty) 209 | getAR _ _ = findInPCX 210 | 211 | 212 | -------------------------------------------------------------------------------- /src/Sirea/B.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, 2 | GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 3 | 4 | -- | This module provides the B type behaviors, the primary behavior 5 | -- kind exposed to clients of Sirea. These behaviors operate in IO 6 | -- and with a global resource context (WCX). The runSireaApp action 7 | -- will begin executing a B type behavior. 8 | -- 9 | -- See Also: 10 | -- Sirea.Activate - to activate a B type behavior 11 | -- Sirea.PCX - for use of use of partitioned resource contexts 12 | -- 13 | module Sirea.B 14 | ( B 15 | , wrapB 16 | , unwrapB 17 | ) where 18 | 19 | import Prelude hiding ((.),id) 20 | import Data.Typeable 21 | import Control.Applicative 22 | import Control.Category 23 | import Sirea.Internal.BCross (crossB0) 24 | import Sirea.Behavior 25 | import Sirea.Trans.Static 26 | import Sirea.Partition 27 | import Sirea.PCX 28 | import Sirea.Internal.B0 -- B0 abstract type and instances 29 | 30 | -- | The primary, concrete behavior implementation provided by Sirea. 31 | newtype B x y = B { fromB0 :: StaticB (WrappedArrow (->) (PCX W)) (B0 IO) x y } 32 | deriving ( Category, BFmap, BProd, BSum, BDisjoin 33 | , BZip, BSplit, BTemporal, Behavior, Typeable ) 34 | -- NOT deriving: BDynamic, BCross 35 | 36 | wrapB :: (PCX W -> B0 IO x y) -> B x y 37 | wrapB = B . wrapStatic . WrapArrow 38 | 39 | unwrapB :: B x y -> (PCX W -> B0 IO x y) 40 | unwrapB = unwrapArrow . unwrapStatic . fromB0 41 | 42 | instance BCross B where 43 | bcross = wrapB crossB0 44 | 45 | instance BDynamic B (B0 IO) where 46 | bevalx = wrapB . const . bevalx 47 | 48 | instance BDynamic B B where 49 | bevalx bdt = wrapB $ \ cw -> 50 | let bdt0 = unwrapB bdt cw in 51 | let toB0 = bfmap (`unwrapB` cw) in 52 | bfirst toB0 >>> bevalx bdt0 53 | 54 | 55 | -------------------------------------------------------------------------------- /src/Sirea/Clock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | -- | Clock is a behavior representing access to the current time. In 4 | -- Sirea, access to time is an ambient authority, available in every 5 | -- partition. A clock must be considered a stateful resource because 6 | -- it logically involves access to an external clock (which provides 7 | -- the 0 time) even though it's implemented as a simple transform of 8 | -- the input signal. 9 | -- 10 | -- These clocks are logical. bclockSeconds will update every second, 11 | -- on the second, starting from the 0 time. Time values in Sirea are 12 | -- MJD, so 0 time is midnight, November 17, 1858, Greenwich. Clocks 13 | -- are specified with a period and offset. In the resource discovery 14 | -- concept, you effectively can discover any clock you can specify. 15 | -- (You aren't creating the clock, just finding one that fits your 16 | -- needs.) Clocks can be accessed in terms of tick count or time. 17 | -- 18 | -- Clocks are useful for various synchronization, scheduling, and 19 | -- testing patterns. But high-frequency (low period) clocks are very 20 | -- expensive to model. Computation grows directly with frequency. 21 | -- Alternatives to clocks may offer greater precision at lower cost. 22 | -- See Sirea.TimeTrigger, Sirea.TimeStamp, and animated state models 23 | -- (in sirea-state) for possible alternatives. 24 | -- 25 | module Sirea.Clock 26 | ( ClockSpec(..) 27 | , bclockTickTime, bclockTick, bclockTime 28 | , btickOfFreq, bclockOfFreq 29 | , bclockHours, bclockMinutes, bclockSeconds 30 | ) where 31 | 32 | import Control.Arrow (first) 33 | import Control.Exception (assert) 34 | import Data.Ratio 35 | import Data.IORef 36 | import Data.Maybe (isNothing) 37 | import Sirea.B 38 | import Sirea.Time 39 | import Sirea.UnsafeLink 40 | import Sirea.Behavior 41 | import Sirea.Signal 42 | import Sirea.Internal.SigType 43 | import Sirea.Partition (Partition) 44 | 45 | -- | ClockSpec specifies when a clock ticks and tocks. 46 | -- 47 | -- clock_period: period in seconds (recip of frequency) 48 | -- clock_offset: 0 offset in seconds. 49 | -- 50 | -- These logical clocks are MJD-relative, but use a simplified time 51 | -- concept (e.g. excluding leap-seconds). Within their simplified 52 | -- time model, they are perfect - never skipping or slowing, and 53 | -- always ticking on some exact value. Sirea will report the clock 54 | -- within the limits of its own precision (i.e. up to once per nano 55 | -- second, as of this writing). 56 | -- 57 | -- All periods are valid, but a clock with period 0 will never tick 58 | -- and one with a negative period will tick downwards (which is only 59 | -- relevant if you're observing tick-count instead of time). All 60 | -- offsets are valid. 61 | -- 62 | data ClockSpec = ClockSpec 63 | { clock_period :: !Rational -- period in seconds 64 | , clock_offset :: !Rational -- offset from MJD 0 in seconds 65 | } deriving (Show,Eq) 66 | 67 | -- | Observe a clock with both tick-count and associated time. When 68 | -- you start observing will not affect the clock, i.e. logically the 69 | -- clock is an external resource that behaves independently of any 70 | -- observer. 71 | bclockTickTime :: (Partition p) => ClockSpec -> B (S p ()) (S p (Integer,T)) 72 | bclockTickTime cs@(ClockSpec p o) = 73 | if (p < 0) then bclockTickTime (ClockSpec (negate p) o) >>> bfmap (first negate) else 74 | if (p == 0) then bconst (0, tickToTime cs 0) else 75 | if (abs p < hfThresh) then unsafeLinkBL (mkClockHF cs) else 76 | unsafeLinkBL (mkClock cs) 77 | 78 | -- high frequency clocks get special handling 79 | hfThresh :: Rational 80 | hfThresh = 3 % (1000*1000*1000) 81 | 82 | -- | Observe a clock in terms of tick-count. The tick counts will be 83 | -- quite large, unless you use a corresponding offset. 84 | bclockTick :: (Partition p) => ClockSpec -> B (S p ()) (S p Integer) 85 | bclockTick cs = bclockTickTime cs >>> bfmap fst 86 | 87 | -- | Observe a clock in terms of current time. 88 | bclockTime :: (Partition p) => ClockSpec -> B (S p ()) (S p T) 89 | bclockTime cs = bclockTickTime cs >>> bfmap snd 90 | 91 | -- find time associated with a particular tick count for a clock spec. 92 | tickToTime :: ClockSpec -> Integer -> T 93 | tickToTime (ClockSpec p o) n = 94 | let rSecs = o + (p * fromInteger n) in 95 | let nanos = (numerator rSecs * nanosInSec) `div` denominator rSecs in 96 | mkTime 0 nanos 97 | 98 | -- find tick associated with particular time for a clock spec. 99 | timeToTick :: ClockSpec -> T -> Integer 100 | timeToTick (ClockSpec p o) tm = 101 | let nanos = (tmDay tm) * nanosInDay + tmNanos tm in 102 | let rSecs = nanos % nanosInSec in 103 | let nF = (rSecs - o) / p in 104 | floor nF 105 | 106 | -- clockList will return a limited sequence of (tick,time) pairs for 107 | -- a logical clock, capturing the given low and high bounds. There 108 | -- will be at least two elements in this list (one on or before low, 109 | -- one on or after high). 110 | clockList :: ClockSpec -> T -> T -> [(Integer,T)] 111 | clockList cs tLo tHi = assert (tLo < tHi) $ 112 | let nLo = timeToTick cs tLo in 113 | let tClockLo = tickToTime cs nLo in 114 | assert (tLo >= tClockLo) $ -- sanity check 115 | (nLo, tClockLo):clockListN cs tHi (nLo + 1) 116 | 117 | -- increment until we include tHi. Always returns a non-empty list. 118 | clockListN :: ClockSpec -> T -> Integer -> [(Integer,T)] 119 | clockListN cs tHi n = 120 | let tN = tickToTime cs n in 121 | let cl = if (tN >= tHi) then [] else clockListN cs tHi (n+1) in 122 | (n,tN):cl 123 | 124 | -- obtain clock signal from clock list: 125 | clockListToSig :: [(Integer,T)] -> Sig (Integer,T) 126 | clockListToSig [] = assert False $ Sig Nothing Done -- expect non-empty list 127 | clockListToSig (x:xs) = Sig (Just x) (seqFromList $ fmap cu xs) where 128 | cu nt = (snd nt, Just nt) 129 | 130 | 131 | nanosInDay, nanosInSec :: Integer 132 | nanosInDay = 24*60*60 * nanosInSec 133 | nanosInSec = 1000*1000*1000 134 | 135 | -- | For testing, it is often convenient to just obtain a signal 136 | -- that increments periodically at a predictable rate. There may 137 | -- be other uses for it. 138 | btickOfFreq :: (Partition p) => Rational -> B (S p ()) (S p Integer) 139 | btickOfFreq = bclockTick . freqToCS 140 | 141 | -- | Obtain a clock in terms of frquency instead of period. 142 | bclockOfFreq :: (Partition p) => Rational -> B (S p ()) (S p T) 143 | bclockOfFreq = bclockTime . freqToCS 144 | 145 | -- frequency to clockspeck 146 | freqToCS :: Rational -> ClockSpec 147 | freqToCS r = if (0 == r) then ClockSpec 0 0 else ClockSpec (recip r) 0 148 | 149 | -- | A logical hour-clock. Updates every hour on the hour. 150 | bclockHours :: (Partition p) => B (S p ()) (S p T) 151 | bclockHours = bclockOfFreq (1 % 3600) 152 | 153 | -- | A logical minute-clock. Updates every minute on the minute. 154 | bclockMinutes :: (Partition p) => B (S p ()) (S p T) 155 | bclockMinutes = bclockOfFreq (1 % 60) 156 | 157 | -- | A logical second-clock. Updates every second on the second. 158 | bclockSeconds :: (Partition p) => B (S p ()) (S p T) 159 | bclockSeconds = bclockOfFreq 1 160 | 161 | -- very high frequency clocks will need to compute ticks from times 162 | -- rather than vice versa. 163 | mkClockHF :: ClockSpec -> pcx -> LnkUp (Integer,T) -> IO (LnkUp ()) 164 | mkClockHF _ _ = error "TODO: support very high-frequency clocks" 165 | 166 | -- Clock implementation. Logical clocks are external resources, but 167 | -- their behavior is predictable so is computed locally. A concern 168 | -- is that signals are spine-strict: we can't lazily compute the 169 | -- infinite future, and must turn some stability updates into real 170 | -- updates. The last reported tick/time is recorded. 171 | -- 172 | mkClock :: ClockSpec -> pcx -> LnkUp (Integer,T) -> IO (LnkUp ()) 173 | mkClock cs _ ln = 174 | newIORef Nothing >>= \ rf -> -- track time to consider updates. 175 | return (lnClock cs rf ln) 176 | 177 | dtClockStep, dtClockIdle :: DT 178 | dtClockStep = 1.2 -- affects how much is computed per an update step 179 | dtClockIdle = 0.3 -- how near end of last step before computing more 180 | 181 | lnClock :: ClockSpec -> IORef (Maybe T) -> LnkUp (Integer,T) -> LnkUp () 182 | lnClock cs rf lu = LnkUp touch update idle cyc where 183 | touch = ln_touch lu 184 | cyc = ln_cycle lu 185 | idle tS = readIORef rf >>= idle' tS 186 | idle' tS Nothing = ln_idle lu tS -- dead signal... 187 | idle' tS (Just tLast) = 188 | let dt = diffTime tLast (inStableT tS) in 189 | if (dtClockIdle < dt) then ln_idle lu tS else 190 | let tLo = tLast in 191 | let tHi = tLo `addTime` dtClockStep in 192 | let lClock = tail (clockList cs tLo tHi) in 193 | let tU = (snd . head) lClock in 194 | let sClock = clockListToSig lClock in 195 | deliver tS tU sClock 196 | update tS@(StableT tm) tU su = 197 | let tLo = min tm tU in 198 | let (tEnd,_) = sigEnd tLo su in 199 | let tHi = (max tEnd $ max tm tU) `addTime` dtClockStep in 200 | let lClock = clockList cs tLo tHi in 201 | let sClock = clockListToSig lClock `s_mask` su in 202 | deliver tS tU sClock 203 | deliver tS tU sClock = 204 | let (t,m) = sigEnd tU sClock in 205 | let mem = if isNothing m then Nothing else Just t in 206 | writeIORef rf mem >> 207 | ln_update lu tS tU sClock 208 | 209 | -- Find the last values in a signal, given some 210 | -- proposed initial values. 211 | sigEnd :: T -> Sig a -> (T, Maybe a) 212 | sigEnd t (Sig hd tl) = seqEnd t hd tl 213 | 214 | seqEnd :: T -> a -> Seq a -> (T, a) 215 | seqEnd t a Done = (t,a) 216 | seqEnd _ _ (Step t a s) = seqEnd t a s 217 | 218 | 219 | -------------------------------------------------------------------------------- /src/Sirea/DemandMonitor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, 2 | GeneralizedNewtypeDeriving 3 | #-} 4 | 5 | -- | RDP behaviors are effectful, albeit in a constrained manner. A 6 | -- resource's state may be influenced by the set of demands on it. A 7 | -- behavior observing a resource may react to present or anticipated 8 | -- resource state. 9 | -- 10 | -- Demand monitors are a simple, useful resource. 11 | -- 12 | -- The state of a demand monitor resource is simply equal to the set 13 | -- of demand signals sent to it. Demand monitors are modeled with a 14 | -- pair of behaviors: one to impose demand, one to monitor state - 15 | -- respectively called 'demand facet' and 'monitor facet'. 16 | -- 17 | -- Demand monitors support one-to-many or many-to-one communication, 18 | -- and simple collaboration patterns. They are volatile - continuous 19 | -- signals are necessary to keep a value in the monitor, and some 20 | -- values might never be observed. 21 | -- 22 | -- Demand monitors are an 'abundant' resource: an application may 23 | -- access however many it needs. Unfortunately, an unused demand 24 | -- monitor will not be fully GC'd, so it is necessary to avoid 25 | -- gratuitously initializing monitors. 26 | -- 27 | -- The weakness of demand monitors is stability. A demand set will 28 | -- aggregate instability from every contributing demand, which can 29 | -- result in problems scaling if fan-in is large. 30 | -- 31 | -- This module provides concrete demand monitors for BCX, and a 32 | -- generic interface via the HasDemandMonitor typeclass. 33 | -- 34 | module Sirea.DemandMonitor 35 | ( DemandMonitor 36 | , demandMonitor 37 | , bdemand, bmonitor 38 | , activityMonitor 39 | , bactivate, bactive 40 | , demandListMonitor 41 | , bdemandl, bmonitorl 42 | ) where 43 | 44 | -- TODO: Consider making DemandMonitor more compositional, by having 45 | -- a set for input as well as for output. I.e. `Set a ~> Set a` with 46 | -- the input set containing a few elements and the output containing 47 | -- a union of all elements. This would make it easier to work with 48 | -- collections in general. 49 | 50 | import Control.Applicative 51 | import Data.Maybe (isJust) 52 | import Data.Typeable 53 | import Data.Set (Set) 54 | import qualified Data.Set as S 55 | import Sirea.Signal 56 | import Sirea.Behavior 57 | import Sirea.B 58 | import Sirea.UnsafeLink 59 | import Sirea.Partition 60 | import Sirea.PCX 61 | import Sirea.Internal.DemandMonitorData 62 | import Sirea.Internal.B0Impl (wrapLnEqShift) 63 | 64 | -- | DemandMonitor is a synonym for the (demand,monitor) facet pair 65 | type DemandMonitor b p e z = (b (S p e) (S p ()), b (S p ()) (S p z)) 66 | 67 | -- | Obtain a demand monitor resource, as a (demand,monitor) pair. 68 | -- 69 | -- This demand monitor will return the set of active demands. 70 | demandMonitor :: (Ord e, Typeable e, Partition p) => String -> DemandMonitor B p e (Set e) 71 | demandMonitor nm = 72 | let cpToDMD = fmap getDMD . findByNameInPCX nm in 73 | let d = demandFacetB $ fmap fst . cpToDMD in 74 | let m = monitorFacetB $ fmap snd . cpToDMD in 75 | (d,m) 76 | 77 | -- | contribute demands to a set of demands, which can be observed 78 | -- by any 'bmonitor' with the same identifying string. 79 | -- 80 | -- Note that if you use a demand monitor in this fashion, it is wise 81 | -- to use a common string variable to guard against spelling errors 82 | -- or inconsistency in refactoring. Each string discovers a distinct 83 | -- demand monitor resource. 84 | bdemand :: (Ord e, Typeable e, Partition p) => String -> B (S p e) (S p ()) 85 | bdemand = fst . demandMonitor 86 | 87 | -- | observe set of active demands. 88 | bmonitor :: (Ord e, Typeable e, Partition p) => String -> B (S p ()) (S p (Set e)) 89 | bmonitor = snd . demandMonitor 90 | 91 | -- | activityMonitor is a specialized demand monitor with unit type, 92 | -- which means it only monitors whether at least one input signal is 93 | -- active. This observed value is 'True' for durations where there 94 | -- is at least one active demand. 95 | activityMonitor :: (Partition p) => String -> DemandMonitor B p () Bool 96 | activityMonitor nm = 97 | let cpToAMon = fmap getAMon . findByNameInPCX nm in 98 | let d = demandFacetB $ fmap fst . cpToAMon in 99 | let m = monitorFacetB $ fmap snd . cpToAMon in 100 | (d,m) 101 | 102 | -- | activate an activityMonitor resource 103 | bactivate :: (Partition p) => String -> B (S p ()) (S p ()) 104 | bactivate = fst . activityMonitor 105 | 106 | -- | test whether an activityMonitor resource is active. 107 | bactive :: (Partition p) => String -> B (S p ()) (S p Bool) 108 | bactive = snd . activityMonitor 109 | 110 | newtype DMD e = DMD { getDMD :: (DemandAggr e (Set e), MonitorDist (Set e)) } 111 | deriving (Typeable) 112 | 113 | instance (Partition p, Typeable e, Ord e) => Resource p (DMD e) where 114 | locateResource _ cp = DMD <$> newDMD cp 115 | instance (Partition p, Typeable e, Ord e) => NamedResource p (DMD e) 116 | 117 | -- newDMD will return a coupled DemandAggr and MonitorDist pair. 118 | newDMD :: (Partition p, Ord e) => PCX p -> IO (DemandAggr e (Set e), MonitorDist (Set e)) 119 | newDMD cp = 120 | getPSched cp >>= \ pd -> 121 | newMonitorDist pd (s_always S.empty) >>= \ md -> 122 | let luMon = primaryMonitorLnk md in 123 | wrapLnEqShift (==) luMon >>= \ luEq -> 124 | newDemandAggr pd luEq (s_adjeqf (==) . setZip) >>= \ d -> 125 | return (d,md) 126 | 127 | setZip :: (Ord e) => [Sig e] -> Sig (Set e) 128 | setZip [] = s_always S.empty 129 | setZip (s:[]) = s_full_map (Just . maybe S.empty S.singleton) s 130 | setZip ss = s_zip S.union s1 s2 where 131 | (h1,h2) = splitAt (length ss `div` 2) ss 132 | s1 = setZip h1 133 | s2 = setZip h2 134 | 135 | -- TODO: seek more efficient zip operations. 136 | 137 | newtype AMon = AMon { getAMon :: (DemandAggr () Bool, MonitorDist Bool) } 138 | deriving (Typeable) 139 | 140 | instance (Partition p) => Resource p AMon where 141 | locateResource _ cp = AMon <$> newAMon cp 142 | instance (Partition p) => NamedResource p AMon 143 | 144 | -- newAM will return a coupled DemandAggr and MonitorDist pair. 145 | newAMon :: (Partition p) => PCX p -> IO (DemandAggr () Bool, MonitorDist Bool) 146 | newAMon cp = 147 | getPSched cp >>= \ pd -> 148 | newMonitorDist pd (s_always False) >>= \ md -> 149 | let luMon = primaryMonitorLnk md in 150 | wrapLnEqShift (==) luMon >>= \ luEq -> 151 | newDemandAggr pd luEq amonZip >>= \ d -> 152 | return (d,md) 153 | 154 | amonZip :: [Sig ()] -> Sig Bool 155 | amonZip = 156 | s_full_map (Just . isJust) . 157 | s_const () . 158 | foldr s_merge s_never 159 | 160 | demandFacetB :: (Partition p) => (PCX p -> IO (DemandAggr e z)) -> B (S p e) (S p ()) 161 | demandFacetB getDA = bvoid (unsafeLinkB_ lnDem) >>> bconst () where 162 | lnDem cw = getDA cw >>= newDemandLnk 163 | 164 | monitorFacetB :: (Partition p) => (PCX p -> IO (MonitorDist z)) -> B (S p ()) (S p z) 165 | monitorFacetB getMD = unsafeLinkBL lnMon where 166 | lnMon cw lu = getMD cw >>= flip newMonitorLnk lu 167 | 168 | 169 | -- | demandListMonitor is necessary for types that cannot meet the 170 | -- Ord constraint. It behaves similar to demandMonitor, but there 171 | -- are some extra safety concerns: the resulting list has a non 172 | -- deterministic ordering, and may contain duplicates, neither of 173 | -- which should affect observable behavior. Developers must be 174 | -- careful to only use the monitored results in a context or manner 175 | -- where ordering or duplication is irrelevant. 176 | demandListMonitor :: (Partition p, Typeable e) => String -> DemandMonitor B p e [e] 177 | demandListMonitor nm = 178 | let cpToDMD = fmap getLDMD . findByNameInPCX nm in 179 | let d = demandFacetB $ fmap fst . cpToDMD in 180 | let m = monitorFacetB $ fmap snd . cpToDMD in 181 | (d,m) 182 | 183 | -- | Contribute demand to a list; useful if type lacks Ord property. 184 | -- Demand lists are entirely distinct from demand sets of bdemand. 185 | bdemandl :: (Partition p, Typeable e) => String -> B (S p e) (S p ()) 186 | bdemandl = fst . demandListMonitor 187 | 188 | -- | Monitor a list of demands. Note that the list should be treated 189 | -- as a set - i.e. ordering and duplication must not affect observed 190 | -- behavior (otherwise this introduces non-determinism). 191 | bmonitorl :: (Partition p, Typeable e) => String -> B (S p ()) (S p [e]) 192 | bmonitorl = snd . demandListMonitor 193 | 194 | newtype LDMD e = LDMD { getLDMD :: (DemandAggr e [e], MonitorDist [e]) } deriving (Typeable) 195 | instance (Partition p, Typeable e) => Resource p (LDMD e) where 196 | locateResource _ cp = LDMD <$> newLDMD cp 197 | instance (Partition p, Typeable e) => NamedResource p (LDMD e) 198 | 199 | -- newDMD will return a coupled DemandAggr and MonitorDist pair. 200 | newLDMD :: (Partition p) => PCX p -> IO (DemandAggr e [e], MonitorDist [e]) 201 | newLDMD cp = 202 | getPSched cp >>= \ pd -> 203 | newMonitorDist pd (s_always []) >>= \ md -> 204 | let lu = primaryMonitorLnk md in 205 | newDemandAggr pd lu sigZipLists >>= \ d -> 206 | return (d,md) 207 | 208 | sigZipLists :: [Sig e] -> Sig [e] 209 | sigZipLists = foldr (s_full_zip jf) (s_always []) 210 | where jf (Just x) (Just xs) = Just (x:xs) 211 | jf _ xs = xs 212 | 213 | 214 | 215 | 216 | 217 | 218 | -------------------------------------------------------------------------------- /src/Sirea/Foreach.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmbarbour/Sirea/11706a8c2621af41c96da778afeb2e763d7c49cd/src/Sirea/Foreach.hs -------------------------------------------------------------------------------- /src/Sirea/Internal/B0.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | -- | `B0 m x y` is the raw, primitive behavior type in Sirea. 5 | module Sirea.Internal.B0 6 | ( B0 7 | ) where 8 | 9 | import Sirea.Behavior 10 | import Sirea.Internal.B0Type (B0) 11 | import Sirea.Internal.B0Impl 12 | import Sirea.Internal.B0Dynamic 13 | import Data.Typeable 14 | 15 | instance (Typeable1 m) => Typeable2 (B0 m) where 16 | typeOf2 b = mkTyConApp tcB0 [typeOf1 (getM b)] 17 | where tcB0 = mkTyCon3 "sirea-core" "Sirea.Internal.B0" "B0" 18 | 19 | getM :: B0 m x y -> m () 20 | getM _ = undefined 21 | 22 | alwaysEq :: a -> b -> Bool 23 | alwaysEq = (const . const) True 24 | 25 | instance (Monad m) => BFmap (B0 m) where 26 | bfmap = fmapB0 27 | bconst c = constB0 c >>> unsafeEqShiftB0 alwaysEq 28 | bstrat = stratB0 29 | btouch = touchB0 30 | badjeqf = adjeqfB0 >>> unsafeEqShiftB0 (==) 31 | instance (Monad m) => BProd (B0 m) where 32 | bfirst = firstB0 33 | bdup = dupB0 34 | b1i = s1iB0 35 | b1e = s1eB0 36 | btrivial = trivialB0 37 | bswap = swapB0 38 | bassoclp = assoclpB0 39 | instance (Monad m) => BSum (B0 m) where 40 | bleft = leftB0 41 | bmirror = mirrorB0 42 | bmerge = mergeB0 43 | b0i = s0iB0 44 | b0e = s0eB0 45 | bvacuous = vacuousB0 46 | bassocls = assoclsB0 47 | instance (Monad m) => BZip (B0 m) where 48 | bzap = zapB0 49 | instance (Monad m) => BSplit (B0 m) where 50 | bsplit = splitB0 51 | instance (Monad m) => BDisjoin (B0 m) where 52 | bdisjoin = disjoinB0 53 | instance (Monad m) => BTemporal (B0 m) where 54 | bdelay = delayB0 55 | bsynch = synchB0 56 | instance (Monad m) => Behavior (B0 m) 57 | 58 | -- Unfortunately, we can't have dynamic behaviors for type B 59 | -- due to update scheduling issues. evalB without scheduler 60 | -- access must perform touches in the update phase, which is 61 | -- a problem (since it can lead to premature updates). 62 | -- 63 | instance (Monad m) => BDynamic (B0 m) (B0 m) where 64 | bevalx = evalB0 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /src/Sirea/Internal/B0Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GADTs #-} 2 | 3 | module Sirea.Internal.B0Compile 4 | ( compileB0 5 | , compileB0s1 6 | , B0s1(..) 7 | , compileB0s2 8 | ) where 9 | 10 | import Prelude hiding ((.),id) 11 | import Sirea.Internal.STypes 12 | import Sirea.Internal.B0Type 13 | import Sirea.Internal.LTypes 14 | import Control.Exception (assert) 15 | import Control.Category 16 | 17 | 18 | -- | Compilation of Sirea `B0` type behaviors. 19 | -- 20 | -- INPUTS: 21 | -- B0 m x y - behavior to compile 22 | -- LCaps m x - tracks time, common capabilities 23 | -- LnkM m y - where the output signal goes 24 | -- OUTPUTS: 25 | -- LCaps m y - timings of outputs 26 | -- m (LnkM m x) - constructor for input signal 27 | -- 28 | -- Note: there is no integration with the Stepper at this point. Any 29 | -- behaviors that need staging via the Stepper should have achieved 30 | -- it via MkLnk. 31 | compileB0 :: (Monad m) => B0 m x y -> LCapsM m x -> LnkM m y -> (LCapsM m y, m (LnkM m x)) 32 | compileB0 bxy lcx lny = 33 | assert (lc_valid lcx) $ 34 | let (bxy', lcy) = compileB0s1 bxy lcx in 35 | assert (lc_valid lcy) $ 36 | let lnx = compileB0s2 bxy' lny in 37 | (lcy, lnx) 38 | 39 | -- | This is an initial left-to-right compile within a behavior. It 40 | -- computes the timing properties of the resulting signal, applies 41 | -- time-dependent transforms (B0_latent). 42 | compileB0s1 :: (Monad m) => B0 m x z -> LCapsM m x -> (B0s1 m x z, LCapsM m z) 43 | compileB0s1 (B0_pipe bxy byz) lcx = 44 | let (bxy', lcy) = compileB0s1 bxy lcx in 45 | assert (lc_valid lcy) $ 46 | assert ((not . ln_dead) lcy) $ 47 | let (byz', lcz) = compileB0s1 byz lcy in 48 | (B0s1_pipe bxy' byz', lcz) 49 | compileB0s1 (B0_first bef) lcx = 50 | let lce = ln_fst lcx in 51 | let (bef', lcf) = compileB0s1 bef lce in 52 | let lcz = LnkProd lcf (ln_snd lcx) in 53 | (B0s1_first bef', lcz) 54 | compileB0s1 (B0_left bef) lcx = 55 | let lce = ln_left lcx in 56 | if (ln_dead lce) -- dead-code elimination for :|: input 57 | then (B0s1_left deadOnInputB0s1, LnkSum LnkDead (ln_right lcx)) 58 | else let (bef',lcf) = compileB0s1 bef lce in 59 | assert (not (ln_dead lcf)) $ 60 | let lcz = LnkSum lcf (ln_right lcx) in 61 | (B0s1_left bef', lcz) 62 | --compileB0s1 (B0_latent fn) lcx = 63 | -- compileB0s1 (fn lcx) lcx 64 | compileB0s1 (B0_mkLnk fn mkLnk) lcx = 65 | (B0s1_mkLnk (mkLnk lcx), fn lcx) 66 | 67 | 68 | -- | B0s1 is basically B0 after the first stage compile. The LCaps 69 | -- are applied and processed already, so only Lnk is left. 70 | data B0s1 m x y where 71 | B0s1_mkLnk :: (LnkM m y -> m (LnkM m x)) -> B0s1 m x y 72 | B0s1_pipe :: B0s1 m x y -> B0s1 m y z -> B0s1 m x z 73 | B0s1_first :: B0s1 m x x' -> B0s1 m (x :&: y) (x' :&: y) 74 | B0s1_left :: B0s1 m x x' -> B0s1 m (x :|: y) (x' :|: y) 75 | 76 | instance (Monad m) => Category (B0s1 m) where 77 | id = B0s1_mkLnk return 78 | (.) = flip B0s1_pipe 79 | 80 | -- | This is the right-to-left pass to build the behavior. 81 | compileB0s2 :: (Monad m) => B0s1 m x z -> LnkM m z -> m (LnkM m x) 82 | compileB0s2 (B0s1_pipe bxy byz) lnz = 83 | compileB0s2 byz lnz >>= compileB0s2 bxy 84 | compileB0s2 (B0s1_first bef) lnz = 85 | compileB0s2 bef (ln_fst lnz) >>= \ lne -> 86 | return (LnkProd lne (ln_snd lnz)) 87 | compileB0s2 (B0s1_left bef) lnz = 88 | compileB0s2 bef (ln_left lnz) >>= \ lne -> 89 | return (LnkSum lne (ln_right lnz)) 90 | compileB0s2 (B0s1_mkLnk mkLnk) lnz = mkLnk lnz 91 | 92 | -- | deadOnInputB0 simply returns LnkDead. Assumption: already have 93 | -- proven the input is dead. Injected by compileB0s1 when B0_left is 94 | -- dead on input; goal is to prevent unnecessary construction of 95 | -- resources (such as partition threads). 96 | deadOnInputB0s1 :: (Monad m) => B0s1 m x y 97 | deadOnInputB0s1 = B0s1_mkLnk (const (return LnkDead)) 98 | 99 | 100 | 101 | -- TODO (Maybe): 102 | -- Compute maximum internal latency for a behavior. 103 | -- Could be used for shutdown behavior. 104 | 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /src/Sirea/Internal/B0Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeOperators #-} 2 | 3 | -- | Type B0 is the primitive behavior type in Sirea. It operates in 4 | -- a hidden applicative monad of kind 'm'. Hiding the monad ensures 5 | -- effects are performed with secure capabilities. 6 | module Sirea.Internal.B0Type 7 | ( B0(..) 8 | ) where 9 | 10 | import Sirea.Internal.STypes 11 | import Sirea.Internal.LTypes 12 | 13 | -- | B0 m x y describes an RDP behavior that is implemented in a 14 | -- hidden, applicative monad m to help control effects. Access to 15 | -- effects is instead regulated through capabilities. 16 | -- 17 | -- RDP behaviors operate under many constraints: spatial idempotence 18 | -- and commutativity, duration coupling, eventless, no accumulation 19 | -- of state over time (i.e. no incremental folds over signals). The 20 | -- limitations make RDP very compositional, but require new idioms 21 | -- and state models to control systems. 22 | -- 23 | -- Behaviors compose much like arrows (from Control.Arrow), but are 24 | -- more constrained due to partitioning, asynchrony, and duration 25 | -- coupling. Developers cannot apply Haskell functions at arbitrary 26 | -- points, nor are all functions on signals valid for RDP. 27 | data B0 m x y where 28 | B0_mkLnk :: (LCapsM m x -> LCapsM m y) 29 | -> (LCapsM m x -> LnkM m y -> m (LnkM m x)) 30 | -> B0 m x y 31 | B0_pipe :: B0 m x y -> B0 m y z -> B0 m x z 32 | B0_first :: B0 m x x' -> B0 m (x :&: y) (x' :&: y) 33 | B0_left :: B0 m x x' -> B0 m (x :|: y) (x' :|: y) 34 | --B0_latent :: (LCaps m x -> B0 m x y) -> B0 m x y 35 | 36 | -- Thoughts: 37 | -- Could rewriting improve optimizations for piping B0_mkLnk elements? 38 | 39 | 40 | -------------------------------------------------------------------------------- /src/Sirea/Internal/CC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | -- | RDP is designed for object capability security. Sirea attempts 4 | -- to remain true to this design at least for the B0 type. Haskell, 5 | -- unfortunately, makes it painful to remain faithful to object 6 | -- capability security model (due to inadequate support from the 7 | -- module system), so the main B type provides access to general 8 | -- IO. 9 | module Sirea.Internal.CC 10 | ( CC(..) 11 | , Ref(..), writeRef', modifyRef, modifyRef' 12 | , RefIO, newRefIO 13 | , Sched(..) 14 | ) where 15 | 16 | import Sirea.Time (T) 17 | import Data.IORef 18 | 19 | -- | CC is a set of capabilities and similar features processed on 20 | -- the forward compilation pass through a behavior. This includes 21 | -- latencies (which also enables delay fusion optimizations) and 22 | -- a set of local operations: scheduling, references. 23 | -- 24 | -- Basically, these are the 'common computational capabilities' that 25 | -- are considered ambient in an application. 26 | -- 27 | -- Note that CC's must generally be constructed purely. This is why 28 | -- 'getSched' is provided as an effect, since it generally needs to 29 | -- tap PCX at bcross. 30 | -- 31 | data CC m = CC 32 | { cc_getSched :: !(m (Sched m)) 33 | , cc_newRef :: !(forall a . a -> m (Ref m a)) 34 | } 35 | 36 | -- | A reference type modeled as a pair of read, write capabilities. 37 | data Ref m a = Ref 38 | { readRef :: !(m a) 39 | , writeRef :: !(a -> m ()) 40 | } 41 | 42 | -- | strict write. 43 | writeRef' :: Ref m a -> a -> m () 44 | writeRef' rf a = a `seq` writeRef rf a 45 | 46 | -- | modify a reference. 47 | modifyRef :: (Monad m) => Ref m a -> (a -> a) -> m () 48 | modifyRef rf fn = readRef rf >>= writeRef rf . fn 49 | 50 | -- | strict modify reference 51 | modifyRef' :: (Monad m) => Ref m a -> (a -> a) -> m () 52 | modifyRef' rf fn = readRef rf >>= writeRef' rf . fn 53 | 54 | type RefIO a = Ref IO a 55 | 56 | newRefIO :: a -> IO (RefIO a) 57 | newRefIO a = 58 | newIORef a >>= \ rf -> 59 | return (Ref (readIORef rf) (writeIORef rf)) 60 | 61 | -- | Sched is a useful set of capabilities for scheduling actions 62 | -- for a thread or resource. 63 | -- 64 | -- stepTime -- get time of current step; constant per step 65 | -- onNextStep -- schedule an action to occur next step; trigger 66 | -- next step to run; runs in 'ln_touch' phase 67 | -- onUpdPhase -- schedule action to occur on 'ln_update' phase 68 | -- onStepEnd -- schedule action to occur after update phase 69 | -- eventually -- schedule action to occur in near future, but 70 | -- after some time has passed 71 | -- 72 | -- `onNextStep` and `eventually` will be MT-safe (can be called from 73 | -- helper threads or partitions). All others must be used from the 74 | -- partition in which they apply. Eventual actions run in batches, 75 | -- controlled by an external heartbeat; the timing is not precise, 76 | -- but (subject to tuning and system health) runs at 10-20Hz. This 77 | -- makes it useful for cleanup or time-insensitive periodic tasks. 78 | -- 79 | -- Sirea currently runs three phases per step. The first phase will 80 | -- run ln_touch operations to announce a future update, and possibly 81 | -- an ln_cycle operation to detect and cut cycles. The second phase 82 | -- propagates all ln_update operations, or ln_idle if the update is 83 | -- just for stability. The final phase, onStepEnd, will propagate 84 | -- batched updates to remote partitions, and maybe perform a little 85 | -- cleanup or run any 'unsafeOnUpdate' actions. 86 | -- 87 | data Sched m = Sched 88 | { stepTime :: !(m T) 89 | , onNextStep :: !(m () -> m ()) 90 | , onUpdPhase :: !(m () -> m ()) 91 | , onStepEnd :: !(m () -> m ()) 92 | , eventually :: !(m () -> m ()) 93 | } 94 | 95 | 96 | -------------------------------------------------------------------------------- /src/Sirea/Internal/Choke.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | RDP is able to model feedback cycles with shared resources. For 3 | -- demand monitors, a cycle might be: 4 | -- 5 | -- monitor >>> bfmap foo >>> bdelay 0.1 >>> demand 6 | -- 7 | -- Logically, the above behavior will cycle at 10Hz. Without choke, 8 | -- Sirea would compute it as fast as possible, perhaps at 10kHz, and 9 | -- thus be 9990 cycles ahead by the time one second had passed. That 10 | -- would be an inefficient use of CPU and memory, and risks rework 11 | -- for values speculated several minutes ahead. 12 | -- 13 | -- Cyclic feedback can model interactive systems and coordination 14 | -- patterns. However, cycles are expensive to compute and speculate. 15 | -- Due to RDP's support for effects, there is no magical fixpoint. 16 | -- Each full cycle involves at least one 'runStepper' call at each 17 | -- partition involved in the cycle. 18 | -- 19 | -- Developers are encouraged to avoid cycles where possible, instead 20 | -- favor animated state models, which compute fixpoints of futures. 21 | -- But cycles cannot be avoided entirely in open systems, so RDP and 22 | -- Sirea must handle them robustly and efficiently. Potential cycles 23 | -- are choked at every resource that might introduce them (state and 24 | -- demand monitors, mostly). 25 | -- 26 | -- Choking ensures a sane behavior: we speculate just fractions of a 27 | -- second, and the equilibrium rate for updates is same as logical 28 | -- frequency. The physical computation is not tightly coupled to the 29 | -- logical frequency - e.g. it would run in bursts for frequencies 30 | -- much higher than Sirea's heartbeat rate. 31 | -- 32 | -- To improve anticipation, choke uses a heuristic equilibrium such 33 | -- that speculation runs a rough number of cycles ahead. Choke is 34 | -- introduced implicitly at resources that need it, e.g. all demand 35 | -- monitors are choked. 36 | -- 37 | -- A second concern regarding cycles is interaction with ln_touch. 38 | -- 39 | -- A cycle within a partition is broken across steps. This ensures 40 | -- each step performs a predictable amount of computation before 41 | -- returning, though this does hurt snapshot consistency across the 42 | -- cyclic resource. To keep more computation in the step, cycles are 43 | -- detected within each partition (using ln_cycle) and breaks occur 44 | -- at most once per cycle. 45 | -- 46 | -- TODO: consider developing some sort of EqChoke to eliminate false 47 | -- updates, to avoid unnecessary rework. 48 | -- 49 | module Sirea.Internal.Choke 50 | ( newChoke 51 | ) where 52 | 53 | import Data.IORef 54 | import Data.Unique 55 | import qualified Data.Set as S 56 | import Control.Monad (unless, when) 57 | import Control.Exception (assert) 58 | import Sirea.Signal 59 | import Sirea.Time 60 | import Sirea.UnsafeLink 61 | import Sirea.Internal.Tuning (tAncient, dtFutureChoke) 62 | import Sirea.Internal.LTypes 63 | import Sirea.Partition 64 | 65 | -- Q: When do I clear CycSt? 66 | -- A: I can clear when the model becomes inactive. 67 | 68 | data Choke z = Choke 69 | { ck_link :: !(LnkUp z) 70 | , ck_ident :: !Unique 71 | , ck_cycle :: !(IORef CycSt) 72 | , ck_data :: !(IORef (CKD z)) 73 | , ck_psched :: !PSched 74 | } 75 | data CKD z = CKD 76 | { ckd_stable :: !StableT -- last reported stability 77 | , ckd_expect :: !Bool -- touched by main link 78 | , ckd_flush :: !Bool -- flush active this step? 79 | , ckd_update :: !(UPD z) -- pending update 80 | } 81 | data CycSt = CycUntested | CycTested | CycDetected 82 | data UPD z = Idle | Update !(Sig z) {-# UNPACK #-} !T 83 | 84 | ckdZero :: CKD z 85 | ckdZero = CKD (StableT tAncient) False False Idle 86 | 87 | newChoke :: PSched -> LnkUp z -> IO (LnkUp z) 88 | newChoke pd lu = 89 | newUnique >>= \ u -> 90 | newIORef CycUntested >>= \ rfCyc -> 91 | newIORef ckdZero >>= \ rfDat -> 92 | let ck = Choke lu u rfCyc rfDat pd in 93 | return (chokeLnk ck) 94 | 95 | -- the main choke behavior 96 | chokeLnk :: Choke z -> LnkUp z 97 | chokeLnk ck = LnkUp touch update idle cyc where 98 | touch = chokeTouch ck 99 | cyc = chokeCyc ck 100 | update tS tU su = chokeLinkUpdate ck tS $ applyUpd tU su 101 | idle tS = chokeLinkUpdate ck tS id 102 | 103 | -- compose or piggyback updates 104 | applyUpd :: T -> Sig z -> UPD z -> UPD z 105 | applyUpd tU su Idle = Update su tU 106 | applyUpd tU su (Update s0 tU0) = 107 | if (tU > tU0) then Update (s_switch' s0 tU su) tU0 108 | else Update su tU 109 | 110 | -- chokeTouch records and reports a touch on the main link. 111 | chokeTouch :: Choke z -> IO () 112 | chokeTouch ck = 113 | readIORef (ck_data ck) >>= \ ckd -> 114 | unless (ckd_expect ckd) $ 115 | let ckd' = ckd { ckd_expect = True } in 116 | writeIORef (ck_data ck) ckd' >> 117 | unless (ckdActive ckd) (chokeInit ck) 118 | 119 | ckdActive :: CKD z -> Bool 120 | ckdActive ckd = ckd_expect ckd || ckd_flush ckd 121 | 122 | -- flush forces an update to be emitted downstream even when there 123 | -- is no upstream update. This is used to break cycles or deliver 124 | -- the updates on the next step. chokeFlush must be executed during 125 | -- the touch phase. 126 | chokeFlush :: Choke z -> IO () 127 | chokeFlush ck = 128 | readIORef (ck_data ck) >>= \ ckd -> 129 | unless (ckd_flush ckd) $ 130 | let ckd' = ckd { ckd_flush = True } in 131 | writeIORef (ck_data ck) ckd' >> 132 | onUpdPhase (ck_psched ck) (chokeFlushUpdate ck) >> 133 | unless (ckdActive ckd) (chokeInit ck) 134 | 135 | -- When choke is activated for any reason, we'll test whether it is 136 | -- part of a cycle, and we'll touch the link to indicate an upcoming 137 | -- update. This happens once per step at most. 138 | -- 139 | -- I'd like to explore techniques to minimize the number of cycle 140 | -- tests, i.e. to avoid this 'flood'. 141 | chokeInit :: Choke z -> IO () 142 | chokeInit ck = tstCyc >> touch where 143 | tstCyc = 144 | readIORef (ck_cycle ck) >>= \ cycSt -> 145 | when (cycUntested cycSt) $ 146 | writeIORef (ck_cycle ck) CycTested >> 147 | ln_cycle (ck_link ck) (S.singleton (ck_ident ck)) 148 | touch = ln_touch (ck_link ck) 149 | 150 | cycUntested :: CycSt -> Bool 151 | cycUntested CycUntested = True 152 | cycUntested _ = False 153 | 154 | cycDetected :: CycSt -> Bool 155 | cycDetected CycDetected = True 156 | cycDetected _ = False 157 | 158 | -- chokeCyc detects partition-local cycles in a step 159 | -- 160 | -- If we're also waiting on an upstream update, we'll need to use 161 | -- flush to break the cycle. We'll assume a cycle. 162 | chokeCyc :: Choke z -> CycleSet -> IO () 163 | chokeCyc ck ns = 164 | readIORef (ck_cycle ck) >>= \ cycSt -> 165 | unless (cycDetected cycSt) $ 166 | if (S.member (ck_ident ck) ns) 167 | then writeIORef (ck_cycle ck) CycDetected >> 168 | chokeFlush ck -- break cycle with flush 169 | else writeIORef (ck_cycle ck) CycTested >> 170 | let ns' = S.insert (ck_ident ck) ns in 171 | ln_cycle (ck_link ck) ns' 172 | 173 | -- update initiated by chokeFlush, runs in update phase 174 | chokeFlushUpdate :: Choke z -> IO () 175 | chokeFlushUpdate ck = 176 | readIORef (ck_data ck) >>= \ ckd -> 177 | readIORef (ck_cycle ck) >>= \ cycSt -> 178 | assert (ckd_flush ckd) $ 179 | let ckd' = ckd { ckd_flush = False } in 180 | let bDone = not (ckdActive ckd') in 181 | let bDeliver = bDone || cycDetected cycSt in 182 | writeIORef (ck_data ck) ckd' >> 183 | when bDone (writeIORef (ck_cycle ck) CycUntested) >> 184 | when bDeliver (chokeDeliver ck) 185 | 186 | 187 | -- main link update or idle 188 | -- 189 | -- If we're in a cycle, we need to decide whether to flush update on 190 | -- next step. Otherwise, we should update this step. 191 | chokeLinkUpdate :: Choke z -> StableT -> (UPD z -> UPD z) -> IO () 192 | chokeLinkUpdate ck tS fn = 193 | readIORef (ck_data ck) >>= \ ckd -> 194 | readIORef (ck_cycle ck) >>= \ cycSt -> 195 | writeIORef (ck_cycle ck) CycUntested >>= \ _ -> 196 | assert (ckd_expect ckd) $ -- should be touched by link 197 | assert (tS >= ckd_stable ckd) $ -- non-decreasing stabiliy 198 | assert (not (cycDetected cycSt && ckd_flush ckd)) $ -- flush runs to break cycle 199 | let upd' = fn (ckd_update ckd) in 200 | let ckd' = ckd { ckd_stable = tS, ckd_expect = False, ckd_update = upd' } in 201 | writeIORef (ck_data ck) ckd' >> 202 | let bWaitForFlush = ckd_flush ckd' in 203 | unless bWaitForFlush $ -- wait for flush to avoid double update 204 | if cycDetected cycSt 205 | then let bSched = (ckd_stable ckd /= tS) || timeToDeliverU tS upd' in 206 | when bSched (onNextStep (ck_psched ck) (chokeFlush ck)) 207 | else chokeDeliver ck 208 | 209 | timeToDeliverU :: StableT -> UPD z -> Bool 210 | timeToDeliverU _ Idle = False 211 | timeToDeliverU tS (Update _ tU) = timeToDeliver tS tU 212 | 213 | timeToDeliver :: StableT -> T -> Bool 214 | timeToDeliver (StableT tS) tU = tU < (tS `addTime` dtFutureChoke) 215 | 216 | -- Deliver the standing update. Called by chokeFlushUpdate or chokeLinkUpdate. 217 | -- Deliver should run at most once per step. But it may run before link update 218 | -- when a partition-local cycle is detected. 219 | -- 220 | -- The caller is responsible for clearing any cycle information as needed. 221 | chokeDeliver :: Choke z -> IO () 222 | chokeDeliver ck = 223 | readIORef (ck_data ck) >>= \ ckd -> 224 | assert (not (ckd_flush ckd)) $ 225 | let tS = ckd_stable ckd in 226 | let upd = ckd_update ckd in 227 | case upd of 228 | Idle -> ln_idle (ck_link ck) tS 229 | Update su tU -> 230 | if timeToDeliver tS tU 231 | then let ckd' = ckd { ckd_update = Idle } in 232 | ckd' `seq` writeIORef (ck_data ck) ckd' >> 233 | ln_update (ck_link ck) tS tU su 234 | else ln_idle (ck_link ck) tS 235 | 236 | 237 | -------------------------------------------------------------------------------- /src/Sirea/Internal/PTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module Sirea.Internal.PTypes 4 | ( Stepper(..) 5 | , Stopper(..) 6 | , TC(..) 7 | , runTCStep 8 | , addTCRecv, addTCEvent 9 | , addTCWork, addTCSend 10 | , getTCTime 11 | , tcToStepper 12 | ) where 13 | 14 | import Sirea.PCX 15 | import Sirea.Time 16 | import Data.Typeable 17 | import Data.IORef 18 | import Control.Applicative 19 | import Control.Exception (mask_) 20 | import Control.Monad (join) 21 | 22 | -- | Stepper - incremental processing of RDP updates in Sirea. 23 | -- 24 | -- In Sirea, each partition has one Haskell thread, and each Sirea 25 | -- thread has one Stepper object. The stepper is responsible for 26 | -- receiving available signal updates, performing RDP processing, 27 | -- and sending batched updates to other Sirea threads. Between steps 28 | -- the thread may have other responsibilities. 29 | -- 30 | -- A step will run quickly if there is nothing to do. There is no 31 | -- wait for input. However, running a step may cause a wait on 32 | -- output if the target thread is falling behind. Progress for the 33 | -- application requires every Sirea thread to keep up with available 34 | -- updates. 35 | -- 36 | -- runStepper: process available updates, deliver outputs. Returns 37 | -- very quickly if there is nothing to do, so should wait on event 38 | -- or a fast-pased periodic task (e.g. render frame) after a step. 39 | -- 40 | -- addStepperEvent: add a callback to occur when work is available. 41 | -- The callback must be wait free, and must not call runStepper 42 | -- itself. Typically used with MVars to wait for available input. 43 | -- The event is called from non-partition threads, and should not 44 | -- call runStepper. Event is removed when called or by runStepper. 45 | -- 46 | data Stepper = Stepper 47 | { runStepper :: IO () -- ^ synchronous incremental step 48 | , addStepperEvent :: IO () -> IO () -- ^ notify of work to do 49 | } 50 | 51 | -- | Stopper should provide a way to gracefully halt Sirea threads. 52 | -- For most threads (except for the main thread) the Stopper is 53 | -- called only after stopping the application signal, so activity 54 | -- should have already been halted when runStopper is called. Any 55 | -- final cleanup tasks can be peformed and the thread dropped after 56 | -- runStopper. For the main thread, the client calls Stopper to halt 57 | -- the SireaApp as a whole (see Sirea.Build). 58 | -- 59 | -- Stopping may take a while, so events provide feedback for when a 60 | -- thread or application is done with all cleanup. 61 | -- 62 | -- Sirea shifts runStopper operation to occur as a runStepper task. 63 | -- This ensures need only to wait on Stepper events, and simplifies 64 | -- thread safety issues. 65 | data Stopper = Stopper 66 | { runStopper :: IO () -- ^ asynchronous begin stop 67 | , addStopperEvent :: IO () -> IO () -- ^ notify when stopped 68 | } 69 | 70 | -- | TC is the thread context - basically a small set of queues in 71 | -- IORefs, and some initialization status (for partitions other than 72 | -- P0, keep track to shutdown later). 73 | -- tc_init :: for initialization; atomic 74 | -- tc_recv :: either event or work; atomic 75 | -- tc_work :: phased tasks, repeats until empty; not atomic 76 | -- tc_send :: tasks to perform at end of round; not atomic 77 | -- tc_time :: time of step; monotonic, not atomic 78 | -- These are not heavily optimized; they don't need to be, since 79 | -- there are a bounded number of tasks in any queue at once, and 80 | -- received operations are pre-grouped in batches. 81 | data TC = TC 82 | { tc_init :: !(IORef Bool) 83 | , tc_recv :: !(IORef (Either [Event] [Work])) 84 | , tc_work :: !(IORef [Work]) 85 | , tc_send :: !(IORef [Work]) 86 | , tc_time :: !(IORef (T,T)) -- (tEff,tAct) 87 | } deriving (Typeable) 88 | 89 | type Event = IO () 90 | type Work = IO () 91 | 92 | runReverse :: [IO ()] -> IO () 93 | runReverse = sequence_ . reverse 94 | 95 | newTC :: IO TC 96 | newTC = TC <$> newIORef False 97 | <*> newIORef (Left []) 98 | <*> newIORef [] 99 | <*> newIORef [] 100 | <*> newIORef (tZero,tZero) 101 | where tZero = mkTime 0 0 102 | 103 | instance Resource p TC where 104 | locateResource _ _ = newTC 105 | 106 | -- | In each runStepper round: 107 | -- recv tasks are emptied (atomically) then processed 108 | -- work tasks are created by recv, then handled in group 109 | -- send tasks performed at end of stepper round. 110 | -- The `work` phase might run multiple rounds if creates more work. 111 | -- However, `recv` and `send` are once per round. 112 | tcToStepper :: TC -> Stepper 113 | tcToStepper tc = Stepper 114 | { runStepper = runTCStep tc 115 | , addStepperEvent = addTCEvent tc 116 | } 117 | 118 | runTCStep :: TC -> IO () 119 | runTCStep tc = mask_ $ 120 | updateTime tc >> 121 | runTCRecv (tc_recv tc) >> 122 | runTCWork (tc_work tc) >> 123 | runTCSend (tc_send tc) 124 | 125 | -- TCRecv has either event or work. If an event is scheduled, it is 126 | -- dropped when running a step (and must be explicitly rescheduled). 127 | runTCRecv :: IORef (Either [Event] [Work]) -> IO () 128 | runTCRecv rfRecv = 129 | atomicModifyIORef rfRecv swapZero >>= 130 | either dropEvent runWork 131 | where swapZero x = (Left [],x) 132 | dropEvent _ = return () 133 | runWork = runReverse 134 | 135 | -- TCWork may execute multiple phases. 136 | -- 137 | -- If Sirea resources are designed properly, there should be a small 138 | -- bounded number of phases per step. Current design only needs one. 139 | runTCWork :: IORef [Work] -> IO () 140 | runTCWork rfw = 141 | readIORef rfw >>= \ lw -> 142 | writeIORef rfw [] >> 143 | runWork lw 144 | where runWork [] = return () 145 | runWork lw = runReverse lw >> runTCWork rfw 146 | 147 | -- TCSend will empty non-empty outboxes for the round. Usually a 148 | -- small task, since fan-out between partitions is limited by type. 149 | -- Updates in each outbox will be sent as one atomic batch. 150 | -- 151 | -- This operation may wait: each outbox has a semaphore with limited 152 | -- number of in-flight batches. If a fast producer sends to a slower 153 | -- consumer, the producer may end up waiting. 154 | runTCSend :: IORef [Work] -> IO () 155 | runTCSend rfEmit = 156 | readIORef rfEmit >>= \ lw -> 157 | writeIORef rfEmit [] >> 158 | runReverse lw 159 | 160 | -- add work to a partition; will execute at start of next round 161 | addTCRecv :: TC -> Work -> IO () 162 | addTCRecv tc op = join $ atomicModifyIORef (tc_recv tc) putOpTakeEvent 163 | where putOpTakeEvent (Left lEvents) = (Right [op], runReverse lEvents) 164 | putOpTakeEvent (Right lWork) = (Right (op:lWork), return ()) 165 | 166 | addTCEvent :: TC -> Event -> IO () 167 | addTCEvent tc ev = join $ atomicModifyIORef (tc_recv tc) addOrExecEvent 168 | where addOrExecEvent (Left lEvents) = (Left (ev:lEvents), return ()) 169 | addOrExecEvent (Right lWork) = (Right lWork, ev) 170 | 171 | -- work is not modified atomically. 172 | addTCWork :: TC -> Work -> IO () 173 | addTCWork tc op = 174 | let rf = tc_work tc in 175 | readIORef rf >>= \ lw -> 176 | writeIORef rf (op:lw) 177 | 178 | addTCSend :: TC -> Work -> IO () 179 | addTCSend tc op = 180 | let rf = tc_send tc in 181 | readIORef rf >>= \ lw -> 182 | writeIORef rf (op:lw) 183 | 184 | getTCTime :: TC -> IO T 185 | getTCTime tc = fst `fmap` readIORef (tc_time tc) 186 | 187 | -- updateTime time, with heuristics to ensure monotonic update. 188 | updateTime :: TC -> IO () 189 | updateTime tc = 190 | let rf = tc_time tc in 191 | readIORef rf >>= \ ts0 -> 192 | getTime >>= \ tNow -> 193 | let tEff = adjTime ts0 tNow in 194 | tEff `seq` 195 | writeIORef rf (tEff,tNow) 196 | 197 | -- the monotonic time update heuristic 198 | adjTime :: (T,T) -> T -> T 199 | adjTime (tEff0, tAct0) tNow = 200 | let dtAct = tNow `diffTime` tAct0 in -- difference in times. 201 | let dtEst = 0.97 * dtAct in -- heuristic to mitigate sudden shifts in OS clock 202 | let tEst = if (dtEst > 0) then tEff0 `addTime` dtEst 203 | else tEff0 `addTime` 0.0001 204 | in 205 | max tEst tNow 206 | 207 | 208 | -- TO CONSIDER: 209 | -- I could model stop external to the behaviors themselves, halting on a runStepper. 210 | -- Idea is: 211 | -- Users of thread can schedule onStop tasks, i.e. to clean up. 212 | -- We always stop on a runStepper operation. 213 | -- We simply enter a terminating loop until we get the stoppedOnMVar 214 | -- When main thread gets StoppedOnMVar, it returns. 215 | -- I don't believe this would be an improvement, though. What I actually need is a 216 | -- clean model for switching threads when I switch plugins... (eventually, anyway). 217 | -- Maybe it'd be better to design threads with something like this in mind? E.g. in 218 | -- the plugins model itself. 219 | 220 | -------------------------------------------------------------------------------- /src/Sirea/Internal/PulseSensor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances #-} 2 | 3 | 4 | -- | The PulseSensor module supports weakly periodic tasks, usually 5 | -- for local garbage collection for resources like demand monitors, 6 | -- potentially for low-priority polling. Developers don't have much 7 | -- control over the timing of the pulse, except that it runs as part 8 | -- of runStepper and during the `send` phase (after updates have 9 | -- been processed). 10 | -- 11 | -- The pulse is initiated by the main partition P0 on its heartbeat 12 | -- (that is, when it increases stability of the main signal). It 13 | -- propagates independently of the P0 outbox, so there may be some 14 | -- scheduling inefficiency. 15 | -- 16 | -- Pulse events will run in the same order they are added. 17 | -- 18 | module Sirea.Internal.PulseSensor 19 | ( initPulseListener 20 | , getPulseScheduler 21 | , getPulseRunner 22 | ) where 23 | 24 | import Control.Applicative 25 | import Control.Monad (join) 26 | import Data.IORef 27 | import Data.Typeable 28 | --import Sirea.Partition 29 | import Sirea.PCX 30 | import Sirea.Internal.PTypes 31 | 32 | -- TODO: Support exponential-backoff via layers of batches. 33 | -- I.e. at heartbeat, 2*heartbeat, 4*heartbeat, etc. 34 | -- This will make it easier to prevent future computations from 35 | -- running too far ahead, support more robust looping. 36 | 37 | -- | We're building a PulseReq list. This list is not intended for 38 | -- heavy use, and so pays the expense for atomic updates. 39 | type Work = IO () 40 | type OnWork = IO () 41 | newtype PulseReq = PulseReq (IORef (OnWork, [Work])) 42 | deriving (Typeable) 43 | 44 | instance Resource p PulseReq where 45 | locateResource _ _ = PulseReq <$> newIORef (return (), []) 46 | 47 | runPulse :: PulseReq -> IO () 48 | runPulse (PulseReq rf) = 49 | atomicModifyIORef rf takeWork >>= sequence_ . reverse 50 | where takeWork (onW,ls) = ((onW,[]),ls) 51 | 52 | -- add work to pulse, maybe call the work available signal 53 | addWorkToPulse :: PulseReq -> Work -> IO () 54 | addWorkToPulse (PulseReq rf) w = 55 | join (atomicModifyIORef rf putWork) 56 | where putWork (onW,[]) = ((onW,w:[]),onW) 57 | putWork (onW,ls) = ((onW,w:ls),return ()) 58 | 59 | -- note: setWorkAvailableSignal will call immediately if work is available 60 | setWorkAvailableSignal :: PulseReq -> OnWork -> IO () 61 | setWorkAvailableSignal (PulseReq rf) onW = 62 | join (atomicModifyIORef rf setSig) 63 | where setSig (_,[]) = ((onW,[]),return ()) 64 | setSig (_,ls) = ((onW,ls),onW) 65 | 66 | -- initPulseListener sets the OnWork task for a partition to 67 | -- set an onNextStep callback on the next main partition (P0) 68 | -- heartbeat. Basically, we're round-tripping these tasks via 69 | -- the main partition. The main partition heartbeat runs with 70 | -- the maintenance task, though doesn't use the outbox/inbox 71 | -- mechanism. 72 | initPulseListener :: PCX p0 -> PCX p -> IO () 73 | initPulseListener cp0 cp = 74 | findInPCX cp0 >>= \ pr0 -> 75 | findInPCX cp >>= \ prp -> 76 | findInPCX cp >>= \ tc -> 77 | let runW = addTCRecv tc (runPulse prp) in -- callback via onNextStep 78 | let onW = addWorkToPulse pr0 runW in -- add one-time callback to P0's pulse 79 | setWorkAvailableSignal prp onW 80 | 81 | 82 | type PulseScheduler = Work -> IO () 83 | getPulseScheduler :: PCX p -> IO PulseScheduler 84 | getPulseScheduler cp = addWorkToPulse <$> findInPCX cp 85 | 86 | -- PulseRunner for a given partition. 87 | type PulseRunner = IO () 88 | getPulseRunner :: PCX p -> IO PulseRunner 89 | getPulseRunner cp = runPulse <$> findInPCX cp 90 | 91 | 92 | -------------------------------------------------------------------------------- /src/Sirea/Internal/STypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, EmptyDataDecls, DeriveDataTypeable, 2 | MultiParamTypeClasses, FlexibleInstances #-} 3 | 4 | module Sirea.Internal.STypes 5 | ( (:&:) 6 | , (:|:) 7 | , S, S0, S1 8 | --, V 9 | , SigInP 10 | , SigMembr, BuildMembr(..), buildMembr 11 | ) where 12 | 13 | import Data.Typeable -- all are typeable 14 | 15 | -- | (x :&: y). Product of asynchronous or partitioned signals, but 16 | -- x and y will have equal and tightly coupled active periods. For 17 | -- example, if x is active for 300ms, inactive 100ms, then active 18 | -- 600ms, then y will have the same profile. However, asynchronous 19 | -- delays enable a small divergence of exactly when these periods 20 | -- occur. (They'll be synchronized before recombining signals.) 21 | data (:&:) x y deriving(Typeable) 22 | infixr 3 :&: 23 | 24 | -- | (x :|: y). Union or Sum of asynchronous or partitioned signals. 25 | -- Signals are active for different durations, i.e. if x is active 26 | -- 100 ms, inactive 400 ms, then active 100 ms: then y is inactive 27 | -- 100 ms, active up to 400 ms, then inactive 100 ms. (There may be 28 | -- durations where both are inactive.) Due to asynchronous delays 29 | -- the active periods might overlap for statically known periods. 30 | data (:|:) x y deriving(Typeable) 31 | infixr 2 :|: 32 | 33 | -- | (S p a) is a Sig a in partition p. 34 | -- 35 | -- See FRP.Sirea.Signal for a description of signals. RDP developers 36 | -- do not work directly with signals, but rather with behaviors that 37 | -- transform signals. However, a Sirea developer might interact with 38 | -- signals by the `bUnsafeLnk` behavior for FFI and legacy adapters. 39 | -- 40 | -- Partitions represent the spatial distribution of signals, across 41 | -- threads, processes, or heterogeneous systems. Developers can keep 42 | -- certain functionality to certain partitions (or classes thereof). 43 | -- Communication between partitions requires explicit behavior, such 44 | -- as bcross. 45 | -- 46 | -- Partitions must be Data.Typeable to support analysis of types 47 | -- as values. Some types may have special meaning, indicating that 48 | -- extra threads should be constructed when behavior is initiated. 49 | data S p a deriving(Typeable) 50 | 51 | -- a local version of Void (not exported) 52 | data Void deriving(Typeable) 53 | 54 | -- | S0 is the identity type for (:|:). It is a signal that is never 55 | -- active. There are no valid values for it, so it cannot be active. 56 | -- Its existence is for type-level operations, and match signatures 57 | -- to various category and arrow models that need sum identity. 58 | -- 59 | -- S0 is an non-existent signal. 60 | type S0 = S () Void 61 | 62 | -- | S1 is the identity type for (:&:). It is a signal that is never 63 | -- utilized. It's stuck in a limbo partition, so cannot be accessed. 64 | -- Its existence is for type-level operations, and match signatures 65 | -- to various category and arrow models that need product identity. 66 | -- 67 | -- S1 is an imaginary signal. 68 | type S1 = S Void () 69 | 70 | -- might add support for continuous signals? C p x? rather not, though. 71 | -- might add support for collections? (L x) for list of x? 72 | 73 | 74 | -- | (SigMembr x) supports construction of a membrane object given 75 | -- only the type of signal x. This is necessary for BDynamic and 76 | -- possibly other generic programs that process signals without much 77 | -- knowledge of them. SigMembr can also enforce that a signal is a 78 | -- valid instance of the signal type. SigMembr is entirely defined 79 | -- by sirea-core, no ability to extend it in clients. 80 | class SigMembr x where 81 | sigMembr :: (BuildMembr m) => m x 82 | 83 | -- | (BuildMembr m) describes construction of a particular membrane. 84 | -- Membranes, in this case, are ignorant about their types. The 85 | -- membrane type determines what is constructed. Note that GADTs 86 | -- might be necessary to leverage this effectively. 87 | -- 88 | -- (developed for use by BDynamic, but client extensible). 89 | class BuildMembr m where 90 | buildSigMembr :: m (S p a) 91 | buildSumMembr :: m x -> m y -> m (x :|: y) 92 | buildProdMembr :: m x -> m y -> m (x :&: y) 93 | 94 | instance SigMembr (S p a) where 95 | sigMembr = buildSigMembr 96 | instance (SigMembr x, SigMembr y) => SigMembr (x :|: y) where 97 | sigMembr = buildSumMembr sigMembr sigMembr 98 | instance (SigMembr x, SigMembr y) => SigMembr (x :&: y) where 99 | sigMembr = buildProdMembr sigMembr sigMembr 100 | 101 | -- | Function to build a membrane m for a given signal type x. 102 | buildMembr :: (BuildMembr m, SigMembr x) => m x 103 | buildMembr = sigMembr 104 | 105 | -- | (SigInP p x) constrains that complex signal x exists entirely 106 | -- in partition p. This avoids need for implicit bcross in disjoin 107 | -- and eval behaviors, while allowing them to be reasonably generic. 108 | class (SigMembr x) => SigInP p x 109 | instance SigInP p (S p x) 110 | instance (SigInP p x, SigInP p y) => SigInP p (x :&: y) 111 | instance (SigInP p x, SigInP p y) => SigInP p (x :|: y) 112 | 113 | -- would like something that `selects` a signal in p, and extracts a 114 | -- unit signal, in a generic way... that would certainly make disjoin 115 | -- easier to express. This sort of type-driven program would be easy 116 | -- to express in Coq. But I'd also want to optimize which signal is 117 | -- selected (i.e. the cheapest one to receive). 118 | 119 | 120 | -- (V x) lifts collection processing to Sirea's reactive layer. 121 | -- The vector of signals is homogenous, but may have a time-varying 122 | -- finite size. A signal of collections may be converted to a vector 123 | -- of signals and back, i.e.: 124 | -- 125 | -- b (S p [x]) (V (S p x)) 126 | -- b (V (S p x) :&: S p ()) (S p [x]) 127 | -- or maybe 128 | -- b (S p [Maybe x]) (V (S p x)) 129 | -- b (V (S p x) :&: S p ()) (S p [Maybe x]) 130 | -- 131 | -- Vectors are logically synchronous, with every element having the 132 | -- same latency. Though for a complex signals of form `V (y :&: z)` 133 | -- the y and z components may still have varying latencies. 134 | -- 135 | -- THOUGHTS: would it be worthwhile to constrain V to process a 136 | -- maximum static count (V k x), with k in the type-system? This 137 | -- would make V a little less widely useful, but a little more 138 | -- suitable for real-time systems... and still quite useful for 139 | -- dynamic systems, and easier to implement properly. 140 | -- 141 | -- (STATUS: preliminary design, experimental) 142 | -- data V k x 143 | 144 | -- Related to V: 145 | -- 146 | -- A concept of partial-signals might be useful, i.e. one half of an 147 | -- 'if'. Formally, we can get this using S1: 148 | -- type H x = x :|: S1 -- half-signals 149 | -- (x :|: y) ~> H x -- bright btrivial 150 | -- x ~> H x -- b0i >>> bleft bvacuous >>> mirror 151 | -- y ~> H x -- b0i >>> (bvacuous +++ btrivial) 152 | -- H x :|: H x ~> H x -- plumb >>> (bmerge +++ bmerge) where 153 | -- plumb :: (x1 :|: y1) :|: (x2 :|: y2) ~> (x1 :|: x2) :|: (y1 :|: y2) 154 | -- plumb = bassocrs >>> bright plumb2 >>> bassocls 155 | -- plumb2 = bassocls >>> bleft bmirror >>> bassocrs 156 | -- 157 | -- But it is inconvenient to deal with products of partial signals, 158 | -- since each signal might be partial in its own ways. I know of no 159 | -- efficient, effective way to combine (H x :&: H y :&: H z). 160 | -- 161 | -- If vectors have maximum dynamic size, then presumably we could 162 | -- understand them as a vector of H signals values. In that case, 163 | -- it might be better to separate V from H (such that we can have 164 | -- `V k (H x)` explicitly), but we might be able to provide some 165 | -- useful, standard ways to operate on the signals, too. 166 | -- 167 | 168 | 169 | -------------------------------------------------------------------------------- /src/Sirea/Internal/SigType.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Most developers don't need direct access to the representation 3 | -- of signals. The representation used now is basically: 4 | -- (Maybe a, [(T,Maybe a)]) 5 | -- with an assumption that the list is of bounded length or even is 6 | -- spine-strict. The representation is slightly more compact, with a 7 | -- hope of efficiency. 8 | -- 9 | -- The motivation for spine strictness mostly regards the difficulty 10 | -- of reasoning about how memory in lazy structures or closures; an 11 | -- earlier function-based model had trouble with loops: the signals 12 | -- would grow each loop, picking up new operations to perform when 13 | -- queried. 14 | -- 15 | module Sirea.Internal.SigType 16 | ( Sig(..) 17 | , Seq(..) 18 | , seqFirst 19 | , seqFromList, seqToList, seqTakeList 20 | , seqConst0, seqConst1 21 | , seqMap 22 | , seqQuery, seqTrim 23 | , seqQueryPrior 24 | , seqSigup 25 | , seqFilter 26 | , seqAdjeqf 27 | , seqAp 28 | , seqMerge 29 | , seqMask0, seqMask1 30 | , seqAdjn0, seqAdjn1 31 | ) where 32 | 33 | import Sirea.Time (T) 34 | import Control.Exception (assert) 35 | import Control.Applicative 36 | import Data.Maybe (isNothing) 37 | 38 | -- | Sig is an abstract type for discrete-varying signals in Sirea. 39 | -- A signal is defined for all times, but in practice the past is 40 | -- dropped (collected) while the future is updated over time. At any 41 | -- given instant, a Sig is just a small snapshot of the present and 42 | -- near future (and should be bounded in size or duration). 43 | data Sig a = Sig !(Maybe a) (Seq (Maybe a)) 44 | 45 | -- seq is a compact sequence with monotonic time 46 | data Seq a = Step {-# UNPACK #-} !T a (Seq a) | Done 47 | 48 | seqDone :: Seq a 49 | seqDone = Done 50 | 51 | -- concatenate a stop or value 52 | seqFirst :: T -> a -> Seq a -> Seq a 53 | seqFirst t a s = assert (monoTime t s) $ Step t a s 54 | 55 | -- monotonic time for assertions 56 | monoTime :: T -> Seq a -> Bool 57 | monoTime _ Done = True 58 | monoTime t (Step t' _ _) = (t < t') 59 | 60 | -- convert a list to a sequence. The list must be finite and ordered 61 | -- in time. 62 | seqFromList :: [(T,a)] -> Seq a 63 | seqFromList = foldr (uncurry seqFirst) seqDone 64 | 65 | -- convert a sequence to a list. 66 | seqToList :: Seq a -> [(T,a)] 67 | seqToList Done = [] 68 | seqToList (Step t v s) = (t,v):seqToList s 69 | 70 | -- partial sequence to list (elements prior to the query time) 71 | -- will include any element exactly at the queried time. 72 | seqTakeList :: T -> Seq a -> [(T,a)] 73 | seqTakeList _ Done = [] 74 | seqTakeList tq (Step t v s) = 75 | if (tq < t) then [] else 76 | (t,v):seqTakeList tq s 77 | 78 | -- replace values in a sequence with a constant. 79 | -- seqConst0 assumes prior value was Nothing 80 | -- seqConst1 assumes prior value was the constant. 81 | seqConst0, seqConst1 :: c -> Seq (Maybe a) -> Seq (Maybe c) 82 | 83 | seqConst0 c (Step _ Nothing s) = seqConst0 c s 84 | seqConst0 c (Step t (Just _) s) = Step t (Just c) (seqConst1 c s) 85 | seqConst0 _ Done = Done 86 | 87 | seqConst1 c (Step t Nothing s) = Step t Nothing (seqConst0 c s) 88 | seqConst1 c (Step _ (Just _) s) = seqConst1 c s 89 | seqConst1 _ Done = Done 90 | 91 | -- map a function to every value in a sequence. 92 | seqMap :: (a -> b) -> Seq a -> Seq b 93 | seqMap f (Step t v s) = Step t (f v) (seqMap f s) 94 | seqMap _ Done = Done 95 | 96 | {-# RULES "seqMap/id" seqMap id = id #-} 97 | 98 | -- query a signal to obtain its value at a particular time, and the 99 | -- rest of the signal starting from that point. 100 | seqQuery :: a -> T -> Seq a -> (a, Seq a) 101 | seqQuery x _ Done = (x,Done) 102 | seqQuery x tq s@(Step t v s') = 103 | if (tq < t) then (x,s) else 104 | seqQuery v tq s' 105 | 106 | -- query a signal to obtain its value just prior to a given time and 107 | -- the rest of the signal starting from that point. 108 | seqQueryPrior :: a -> T -> Seq a -> (a, Seq a) 109 | seqQueryPrior x _ Done = (x,Done) 110 | seqQueryPrior x tq s@(Step t v s') = 111 | if (tq <= t) then (x,s) else 112 | seqQueryPrior v tq s' 113 | 114 | -- trim is same as query except with just the resulting sequence. 115 | seqTrim :: T -> Seq a -> Seq a 116 | seqTrim _ Done = Done 117 | seqTrim tq s@(Step t _ s') = 118 | if (tq < t) then s else 119 | seqTrim tq s' 120 | 121 | -- switch from one signal to another at a particular time. 122 | -- note the `Maybe a` value is considered the infinite 123 | -- history of the second signal. 124 | seqSigup :: Seq a -> T -> a -> Seq a -> Seq a 125 | seqSigup xs tU y ys = seqSigup_i ays tU xs where 126 | (y',ys') = seqQuery y tU ys 127 | ays = seqFirst tU y' ys' 128 | 129 | seqSigup_i :: Seq a -> T -> Seq a -> Seq a 130 | seqSigup_i ys tU (Step tx v xs) = 131 | if (tx >= tU) then ys else 132 | Step tx v (seqSigup_i ys tU xs) 133 | seqSigup_i ys _ Done = ys 134 | 135 | -- filter a sequence given a function. 136 | seqFilter :: (a -> Bool) -> Seq a -> Seq a 137 | seqFilter _ Done = Done 138 | seqFilter f (Step t v s) = if (f v) then Step t v s' else s' 139 | where s' = seqFilter f s 140 | 141 | -- filter adjacent values, given filter function and initial value. 142 | -- (will also filter adjacent stops or Nothing values) 143 | seqAdjeqf :: (a -> a -> Bool) -> a -> Seq a -> Seq a 144 | seqAdjeqf _ _ Done = Done 145 | seqAdjeqf eq a (Step t a' s) = 146 | if (eq a a') then seqAdjeqf eq a s 147 | else Step t a' (seqAdjeqf eq a' s) 148 | 149 | -- apply values in one signal to functions in another 150 | seqAp :: (a -> b) -> a -> Seq (a -> b) -> Seq a -> Seq b 151 | seqAp f _ Done xs = seqMap f xs 152 | seqAp _ x fs Done = seqMap ($ x) fs 153 | seqAp f x fs@(Step tf f' fs') xs@(Step tx x' xs') = 154 | case compare tf tx of 155 | LT -> Step tf (f' x ) (seqAp f' x fs' xs ) 156 | EQ -> Step tf (f' x') (seqAp f' x' fs' xs') 157 | GT -> Step tx (f x') (seqAp f x' fs xs') 158 | 159 | -- combine two signals, favoring values from the left side. 160 | seqMerge :: Maybe a -> Maybe a -> Seq (Maybe a) -> Seq (Maybe a) -> Seq (Maybe a) 161 | seqMerge Nothing _ Done ys = ys -- left signal done and transparent 162 | seqMerge _ Nothing xs Done = xs -- right signal done and inactive 163 | seqMerge (Just _) _ Done _ = Done -- left signal done and opaque 164 | seqMerge _ y@(Just _) xs Done = seqMap (<|> y) xs -- constant backup 165 | seqMerge Nothing y (Step _ Nothing xs) ys = seqMerge Nothing y xs ys -- false update left 166 | seqMerge x Nothing xs (Step _ Nothing ys) = seqMerge x Nothing xs ys -- false update right 167 | seqMerge x y xs@(Step tx x' xs') ys@(Step ty y' ys') = 168 | case compare tx ty of 169 | LT -> Step tx (x' <|> y ) (seqMerge x' y xs' ys ) 170 | EQ -> Step tx (x' <|> y') (seqMerge x' y' xs' ys') 171 | GT -> let s' = seqMerge x y' xs ys' in 172 | if isNothing x then Step ty y' s' else s' 173 | 174 | -- mask one signal with another. The resulting signal is active only 175 | -- if both signals are active, but has values only from first input. 176 | -- mask0 assumes values are initially masked 177 | -- mask1 assumes values are initially unmasked 178 | seqMask0, seqMask1 :: (Maybe a) -> Seq (Maybe a) -> Seq (Maybe b_) -> Seq (Maybe a) 179 | seqMask0 _ _ Done = Done -- masked from now on 180 | seqMask0 Nothing Done _ = Done -- signal inactive from now on 181 | seqMask0 (Just c) Done ys = seqConst0 c ys -- masking a constant 182 | seqMask0 Nothing (Step _ Nothing xs) ys = seqMask0 Nothing xs ys -- false step left 183 | seqMask0 x xs (Step _ Nothing ys) = seqMask0 x xs ys -- false step right (still masked) 184 | seqMask0 x xs@(Step tx x' xs') ys@(Step ty (Just _) ys') = 185 | case compare tx ty of 186 | LT -> seqMask0 x' xs' ys -- still masked 187 | EQ -> seqUnmask x' tx xs' ys' -- unmask @ new x 188 | GT -> seqUnmask x ty xs ys' -- unmask @ old x 189 | 190 | seqUnmask :: Maybe a -> T -> Seq (Maybe a) -> Seq (Maybe b_) -> Seq (Maybe a) 191 | seqUnmask Nothing _ xs ys = seqMask1 Nothing xs ys -- unmasked Nothing, no change 192 | seqUnmask x tm xs ys = Step tm x (seqMask1 x xs ys) -- unmasked something. 193 | 194 | seqMask1 _ xs Done = xs -- unmasked from now on 195 | seqMask1 Nothing Done _ = Done -- inactive from now on 196 | seqMask1 (Just c) Done ys = seqConst1 c ys -- masking a constant 197 | seqMask1 Nothing (Step _ Nothing xs) ys = seqMask1 Nothing xs ys -- false update left 198 | seqMask1 x xs (Step _ (Just _) ys) = seqMask1 x xs ys -- false update right (still exposed) 199 | seqMask1 x xs@(Step tx x' xs') ys@(Step ty Nothing ys') = 200 | case compare tx ty of 201 | LT -> Step tx x' (seqMask1 x' xs' ys) -- exposed update 202 | EQ -> let s' = seqMask0 x' xs' ys' in 203 | if isNothing x then s' else Step tx Nothing s' 204 | GT -> let s' = seqMask0 x xs ys' in 205 | if isNothing x then s' else Step tx Nothing s' 206 | 207 | -- filter redundant 'Nothing' values. This is implicit for many 208 | -- operations, so is not critical. adjn0 assumes previous value 209 | -- is Nothing, adjn1 asumes otherwise. 210 | seqAdjn0, seqAdjn1 :: Seq (Maybe a) -> Seq (Maybe a) 211 | seqAdjn0 Done = Done 212 | seqAdjn0 (Step _ Nothing s) = seqAdjn0 s 213 | seqAdjn0 (Step t v@(Just _) s) = Step t v (seqAdjn1 s) 214 | 215 | seqAdjn1 Done = Done 216 | seqAdjn1 (Step t Nothing s) = Step t Nothing (seqAdjn0 s) 217 | seqAdjn1 (Step t v@(Just _) s) = Step t v (seqAdjn1 s) 218 | 219 | 220 | -- TODO: 221 | -- Sig describes a discrete-varying signal. But continuous varying 222 | -- signals might be modeled within it - preferably in a manner 223 | -- suitable for symbolic analysis. This likely means one of: 224 | -- * trigonometric interpolation polynomial (sum of m = -n to n of c_m * e^(i*m*x)) 225 | -- * polynomial expressions (sum of i = 0..n of A_i * t^i) 226 | -- Both would allow simple rep as vector of doubles for the coefficients. 227 | -- (But there is a challenge of performing time-shifts on them. Maybe some sort 228 | -- of matrix operation would be necessary.) 229 | -- 230 | -- multi-dimensional curves would be desired anyway, i.e. vectors and 231 | -- matrices of curvatures. Some sort of time-varying bezier surface is 232 | -- also a possibility. 233 | -- 234 | -- Will probably want to handle in separate modules. I don't have the 235 | -- mathematical knowledge for this at the moment, not even to efficiently 236 | 237 | 238 | -------------------------------------------------------------------------------- /src/Sirea/Internal/Thread.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | simple threading support for Partitions and runSireaApp 3 | module Sirea.Internal.Thread 4 | ( StopData(..) 5 | , emptyStopData 6 | , finiStopData 7 | , simplePartitionLoop 8 | , makeStopper 9 | ) where 10 | 11 | import Sirea.Internal.PTypes 12 | 13 | import Data.IORef 14 | import Control.Monad (join) 15 | import Control.Exception (assert) 16 | import Control.Concurrent.MVar 17 | --import Debug.Trace 18 | 19 | data StopData = SD 20 | { shouldStop :: !Bool 21 | , isStopped :: !Bool 22 | , onStopped :: !(IO ()) 23 | } 24 | 25 | makeStopper :: IORef StopData -> Stopper 26 | makeStopper rf = Stopper 27 | { runStopper = atomicStop rf 28 | , addStopperEvent = addStopDataEvent rf } 29 | 30 | emptyStopData :: StopData 31 | emptyStopData = SD False False (return ()) 32 | 33 | atomicStop :: IORef StopData -> IO () 34 | atomicStop rf = atomicModifyIORef rf doStop 35 | where doStop sd = 36 | if shouldStop sd then (sd, ()) else 37 | let sd' = sd { shouldStop = True } in 38 | (sd', ()) 39 | 40 | addStopDataEvent :: IORef StopData -> IO () -> IO () 41 | addStopDataEvent rf ev = join $ atomicModifyIORef rf addEv 42 | where addEv sd = 43 | if (isStopped sd) then (sd, ev) else 44 | let stopEvent = onStopped sd >> ev in 45 | let sd' = sd { onStopped = stopEvent } in 46 | (sd', return ()) 47 | 48 | -- fini should be used only once 49 | finiStopData :: IORef StopData -> IO () 50 | finiStopData rf = join $ atomicModifyIORef rf fini 51 | where fini sd = 52 | assert (shouldStop sd) $ 53 | assert (not $ isStopped sd) $ 54 | let sd' = SD True True (return ()) in 55 | (sd', onStopped sd) 56 | 57 | simplePartitionLoop :: IORef StopData -> Stepper -> IO () 58 | simplePartitionLoop rfStop stepper = 59 | readIORef rfStop >>= \ sd -> 60 | if (shouldStop sd) then stop 61 | else do wait; run; loop 62 | where stop = finiStopData rfStop 63 | wait = newEmptyMVar >>= \ mv -> 64 | addStepperEvent stepper (putMVar mv ()) >> 65 | takeMVar mv 66 | run = runStepper stepper 67 | loop = simplePartitionLoop rfStop stepper 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /src/Sirea/Internal/Tuning.hs: -------------------------------------------------------------------------------- 1 | 2 | -- A single module for all those configuration tuning variables used by Sirea. 3 | module Sirea.Internal.Tuning 4 | ( dtRestart, dtHeartbeat, dtGrace 5 | , dtFutureChoke, dtClockFlush 6 | , dtEqShift, dtAlign 7 | , dtTouch 8 | , dtCompile 9 | , batchesInFlight 10 | , dtDaggrHist, dtMdistHist 11 | , dtFinalize 12 | , tAncient 13 | ) where 14 | 15 | import Sirea.Time (T,DT,mkTime) 16 | 17 | -- The main Sirea application has a few tuning parameters related to 18 | -- periodic updates, heartbeats, startup, restart, and shutdown. RDP 19 | -- models these formally via activity of the main input signal. The 20 | -- main application is treated like any dynamic execution (even runs 21 | -- within a dynamic evaluation). 22 | -- 23 | -- The current heartbeat, 43.2ms, is chosen to a tiny fraction of a 24 | -- day rather (convenient for time represented in MJD). But any 25 | -- heartbeat between 10-30 Hz is reasonable. (Heartbeat in Sirea 26 | -- affects GC and efficiency, and simple IO adapters. But it does 27 | -- not affect semantics or logical frequencies.) 28 | -- 29 | -- The grace period is added to any startup or shutdown, to support 30 | -- speculative evaluation from the start. 31 | dtRestart, dtHeartbeat, dtGrace :: DT 32 | dtRestart = 2.0 -- how long a pause to force a restart 33 | dtHeartbeat = 0.0432 -- heartbeat and periodic increase of stability 34 | dtGrace = dtHeartbeat -- time allotted for graceful start and stop 35 | 36 | -- A small update to stability is not always worth sending. It must 37 | -- be sent within a partition (after ln_touch, to indicate there is 38 | -- no update), but across partitions or steps we are free to drop a 39 | -- few if we deem them insignificant for GC purposes. 40 | -- 41 | -- (Note: this is problematic for high-frequency cycles. E.g. cycle 42 | -- at 40ms might stop updating stability and get 'stuck'.) 43 | --dtInsigStabilityUp :: DT 44 | --dtInsigStabilityUp = 0.05 -- largest insignificant pure-stability update 45 | 46 | -- To control temporal feedback cycles through resources, Sirea will 47 | -- choke processing of updates that apply to values in the distant 48 | -- future. 49 | dtFutureChoke :: DT 50 | dtFutureChoke = 4 * dtHeartbeat 51 | 52 | -- In some cases, such as demand aggregators, stability is bounded 53 | -- by the clock. In these cases, we'll want to ensure a significant 54 | -- update to the clock before updating stability. (If we allow tiny 55 | -- updates to the clock, we'll end up cycling more than needed.) 56 | dtClockFlush :: DT 57 | dtClockFlush = dtHeartbeat / 2 58 | 59 | 60 | -- TODO: develop a combined choke*eqshift that can support some sort 61 | -- of exponential backoff. Not critical for now, but could save much 62 | -- rework if done properly. 63 | 64 | -- For badjeqf and bconst, how far do we peek to find a first point 65 | -- of non-equivalence? If we find no difference, how much further do 66 | -- we seek for a point of ideal alignment to 'swap in' the updated 67 | -- signal? 68 | dtEqShift, dtAlign :: DT 69 | dtEqShift = 6 * dtHeartbeat -- comparison of values 70 | dtAlign = 4 * dtHeartbeat -- extra search for alignment 71 | 72 | -- When we 'btouch', how far (relative to stability) do we cause the 73 | -- signal to be evaluated. Forcing evaluation is mostly useful to 74 | -- control where latencies are introduced. If dtTouch is larger than 75 | -- zero, some rework may be performed but more values are available 76 | -- in real-time. 77 | dtTouch :: DT 78 | dtTouch = dtEqShift / 10 79 | 80 | -- For dynamic behaviors, it's best to install behaviors a little 81 | -- before they're necessary. Doing so can improve system latency and 82 | -- support better speculative evaluation downstream. The tradeoff is 83 | -- potentially much more rework when signals change. I plan to make 84 | -- this more adaptive, eventually. 85 | dtCompile :: DT 86 | dtCompile = dtFutureChoke -- how far to anticipate dynamic behaviors 87 | 88 | -- Communication between partitions in Sirea occurs via bcross, and 89 | -- uses coarse-grained batches to support snapshot consistency and 90 | -- improved efficiency. The number of "batches in flight" is limited 91 | -- to ensure fairness and simplify performance reasoning. (Note that 92 | -- this value is per directed edge between partitions, not global.) 93 | -- 94 | -- Tuning here is a tradeoff. A large number of batches may improve 95 | -- parallelism, piggybacking, and CPU efficiency. However, it may 96 | -- cost memory, latency, and increases drift between partitions. 97 | -- A small number of batches will require more thread switching but 98 | -- may result in tighter tolerances. 99 | -- 100 | -- Bounded buffers provide synchronization and fair scheduling for 101 | -- Sirea partition threads. By themselves, they cannot deadlock. All 102 | -- incoming batches are processed in each 'step' so each step breaks 103 | -- potential deadlocks. However, developers must avoid use of other 104 | -- synchronization mechanisms between threads. 105 | -- 106 | -- Sirea's parallelism is designed to be self-regulating, i.e. the 107 | -- relative efficiency increases when a partition falls behind and 108 | -- has a lot of batches to process. But regulation from batching and 109 | -- piggybacking is soft and subtle compared to bounded buffers. 110 | -- 111 | batchesInFlight :: Int 112 | batchesInFlight = 6 113 | 114 | -- For demand monitors, and other resources based on DemandAggr, we 115 | -- want to keep a small amount of history available to support late 116 | -- arriving demand sources (relative to wall clock). We'll also keep 117 | -- some historical data to accommodate late arriving observers. The 118 | -- demand sources aspect impacts stability, so is more limited. 119 | dtDaggrHist, dtMdistHist :: DT 120 | dtDaggrHist = 0.05 -- how long to tolerate late-arriving demands 121 | dtMdistHist = 0.05 -- how long to tolerate late-arriving observers 122 | 123 | -- Stability values are a heuristic estimate of how far the signal 124 | -- is valid into the future, and help drive computation. But there 125 | -- is no clear indicator that a signal is "done", which can be a 126 | -- problem when performing GC. When stability is used to drive an 127 | -- effect (such as unsafeOnUpdate) a failure is even observable. 128 | -- 129 | -- To help ensure computation completes, we'll add `dtFinalize` to 130 | -- stability when confident sure we're done with a particular link. 131 | dtFinalize :: DT 132 | dtFinalize = 0 -- dtRestart 133 | 134 | 135 | -- In some cases, I want to initialize structures with a lower bound 136 | -- for Time. But I don't want to pay code and performance overheads 137 | -- for a symbolic representation of this lower bound. So I'll just 138 | -- use tAncient to represent a long before-time. 139 | tAncient :: T 140 | tAncient = mkTime (negate aBillionDays) 0 where 141 | aBillionDays = 1000 * 1000 * 1000 142 | 143 | 144 | -------------------------------------------------------------------------------- /src/Sirea/PCX.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-} 2 | 3 | -- | PCX is a context object providing access to abstract, volatile, 4 | -- external resources: FFI, services, state, sensors, actuators, UI. 5 | -- PCX supports the abstraction that these resources already exist, 6 | -- that the client is just locating or discovering them, linking not 7 | -- creating. RDP requires this conservative notion of resources. RDP 8 | -- relies on external resources to provide state, and the ultimate 9 | -- role of an RDP application is to bind and orchestrate resources 10 | -- through use of signals. 11 | -- 12 | -- When resources are external to an application, modularity has a 13 | -- different flavor. Instead of encapsulation, we use partitioning. 14 | -- The idea is basically that a parent application can grant access 15 | -- to different subcontexts for different subprograms. Untrusted 16 | -- subprograms can thus be prevented from interfering with trusted 17 | -- or sensitive subprograms. PCX is conceptually a partition of a 18 | -- larger resource context. 19 | -- 20 | -- PCX resources are necessarily volatile, i.e. because they exist 21 | -- within a Haskell process. However, they may be volatile proxies 22 | -- for persistent state. An advantage of external state resources 23 | -- is natural support for orthogonal persistence. State resources 24 | -- for Sirea shall be persistent unless they have a good, natural 25 | -- explanation to be volatile (e.g short windowed history). 26 | -- 27 | module Sirea.PCX 28 | ( Resource(..) 29 | , NamedResource 30 | , PCX, newPCX 31 | , findInPCX -- lookup by type 32 | , findByNameInPCX -- lookup by type and string 33 | , RPath -- stable resource path descriptor 34 | ) where 35 | 36 | import Data.Typeable 37 | import Data.Dynamic 38 | import Control.Concurrent.MVar 39 | import qualified Data.Map.Strict as M 40 | import Control.Monad.Fix (mfix) 41 | 42 | -- | PCX p - Partitioned Resource Context. 43 | -- 44 | -- A partition context is a vast space of resources. Conceptually, 45 | -- it already holds the resources, and we locate them as needed. In 46 | -- practice, the resource is created on the first lookup and further 47 | -- lookups will find the same resource. Resources are uniquely 48 | -- identified (and located) based on type (via Typeable) and string. 49 | -- 50 | -- A weakness of PCX is that there is no mechanism to GC resources 51 | -- without collecting the whole space. Consequently, developers must 52 | -- use a relatively stable set of resources to avoid growing the 53 | -- memory overheads. If more dynamism is required, it is necessary 54 | -- to create resource types that handle the dynamism internally. 55 | -- 56 | -- PCX is implemented to be MT-safe and reentrant. However, cyclic 57 | -- dependencies are not supported. (I.e. reentrancy only allows the 58 | -- lookup of resources so long as they don't form a cycle.) 59 | -- 60 | data PCX p = PCX 61 | { pcx_path :: !(RPath) 62 | , pcx_store :: !(MVar Store) 63 | } deriving(Typeable) 64 | 65 | type Store = M.Map (TypeRep,String) (MVar Dynamic) 66 | 67 | -- | The PCX RPath is a path of types and strings, ordered from leaf 68 | -- to root. Every resource has a unique path (from newPCX) that is 69 | -- accessible via locateResource. 70 | type RPath = [(TypeRep,String)] 71 | 72 | -- | Resource - can be found inside a PCX. 73 | -- 74 | -- Resources are constructed in IO, but developers should protect an 75 | -- illusion that resources existed prior the locator operation, i.e. 76 | -- we are locating resources, not creating them. This requires: 77 | -- 78 | -- * no observable side-effects in the locator 79 | -- * no observable effects for mere existence of resource 80 | -- * not sensitive to thread in which construction occurs 81 | -- * not sensitive to time of construction 82 | -- 83 | -- We shouldn't see anything unless we interact with resources with 84 | -- further IO operations. If we create a resource but don't ever use 85 | -- it, there should be no significant effects. The most common IO 86 | -- action for creating resources will probably be newIORef. 87 | -- 88 | -- For safety, the idiom is hide the resource type inside a module 89 | -- and wrap the find operation. This can provide some constraints on 90 | -- the lookup operations. 91 | -- 92 | -- Every resource has a unique path relative to a root PCX. The path 93 | -- supports persistence or generation of default states. This path 94 | -- will be stable across program executions. 95 | -- 96 | -- NOTE: While resources may depend on other resources, dependencies 97 | -- must currently be acyclic (due to the implementation of PCX). 98 | -- 99 | class (Typeable r) => Resource p r where 100 | locateResource :: RPath -> PCX p -> IO r 101 | 102 | -- | NamedResource is simply a declaration that allows access to a 103 | -- resource by string. This prevents accidental use of findByName 104 | -- when a resource should be identified only by type and partition. 105 | -- 106 | -- For named resources, findInPCX = findByNameInPCX "" 107 | class (Resource p r) => NamedResource p r 108 | 109 | -- | Find a resource by type. 110 | findInPCX :: (Resource p r) => PCX p -> IO r 111 | findInPCX = findByNameInPCX' "" 112 | 113 | 114 | -- | Find a resource in a partition based on both name and type. 115 | -- 116 | -- Notionally, the resource already exists, we aren't creating it. 117 | -- In practice, the resource is created on the first lookup, and all 118 | -- subsequent lookups (with the same string and type) will return 119 | -- the same resource. To protect notional existence, resources are 120 | -- not to have observable side-effects until we interact with them. 121 | -- 122 | findByNameInPCX :: (NamedResource p r) => String -> PCX p -> IO r 123 | findByNameInPCX = findByNameInPCX' 124 | 125 | findByNameInPCX' :: (Resource p r) => String -> PCX p -> IO r 126 | findByNameInPCX' nm cp = mfix $ \ rForTypeOnly -> 127 | let k = (typeOf rForTypeOnly, nm) in 128 | pcxGetMVK cp k >>= \ (mvk,bFirst) -> 129 | if bFirst 130 | then locateResource (k:pcx_path cp) cp >>= \ r -> 131 | putMVar mvk (toDyn r) >> 132 | return r 133 | else readMVar mvk >>= \ dynR -> 134 | let Just r = fromDynamic dynR in 135 | return r 136 | 137 | -- returns (MVar for element, First lookup (i.e. empty mvar)) 138 | -- The MVar is only written to on the first lookup. 139 | pcxGetMVK :: PCX p -> (TypeRep,String) -> IO (MVar Dynamic, Bool) 140 | pcxGetMVK cp k = 141 | modifyMVar (pcx_store cp) $ \ tbl -> 142 | case M.lookup k tbl of 143 | Just mvk -> return (tbl,(mvk,False)) 144 | Nothing -> 145 | newEmptyMVar >>= \ mvk -> 146 | let tbl' = M.insert k mvk tbl in 147 | return (tbl', tbl' `seq` (mvk,True)) 148 | 149 | -- | newPCX - a `new` resource context. 150 | newPCX :: RPath -> IO (PCX w) 151 | newPCX p = 152 | newMVar M.empty >>= \ s -> 153 | let pcx = PCX { pcx_path = p, pcx_store = s } in 154 | return pcx 155 | 156 | 157 | -------------------------------------------------------------------------------- /src/Sirea/Partition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls, DeriveDataTypeable, 2 | FlexibleInstances, MultiParamTypeClasses #-} 3 | 4 | -- | Reactive Demand Programming (RDP) design is for open, scalable, 5 | -- distributed systems. Sirea is much more humble: just one Haskell 6 | -- process. But it is still useful to model concurrent behaviors in 7 | -- Sirea - for task concurrency, and proof of concept for modeling 8 | -- spatial orchestration. 9 | -- 10 | -- This module provides behaviors for signals to cross Partitions. 11 | -- Each partition has one Haskell thread. Trivial partitions merely 12 | -- process RDP updates, but many represent resources and continuous 13 | -- or periodic tasks (persisting state, maintaining a GLUT window, 14 | -- watching the filesystem, etc.). A typeclass allows clients to 15 | -- create partitions for specific tasks. 16 | -- 17 | -- Sirea makes partitions very convenient - just name them by type, 18 | -- or infer them at `bcross`. This is very declarative. Partition 19 | -- threads are only created if the partition is used. Partitions 20 | -- can be abstracted by typeclass, possibly by existentials. They 21 | -- communicate via inboxes processed on runStepper operations. For 22 | -- weakly periodic tasks (GC, persistence, polling) a pulse message 23 | -- is regularly broadcast across all partitions that need it. 24 | -- 25 | -- Use bdelay with bcross to model the communication overheads, and 26 | -- computation costs within each partition. There is no delay by 27 | -- default. 28 | -- 29 | -- NOTE: Partition threads must use non-blocking IO if they interact 30 | -- with legacy libraries or the operating system. Sirea waits when a 31 | -- thread falls behind (for predictable time and space properties). 32 | -- Blocking IO can cause the app to freeze. (Fork another thread if 33 | -- necessary; just don't block the `runStepper` operation.) 34 | -- 35 | module Sirea.Partition 36 | ( Partition(..) 37 | , BCross(..) 38 | , Pt, P0, W 39 | , Stepper(..) 40 | , Stopper(..) 41 | , PSched, Sched(..) -- re-exported 42 | , getPSched 43 | ) where 44 | 45 | import Sirea.Behavior 46 | import Sirea.PCX 47 | import Sirea.Internal.CC 48 | import Sirea.Internal.PTypes 49 | import Sirea.Internal.Thread 50 | import Sirea.Internal.PulseSensor (getPulseScheduler) 51 | 52 | import Data.Typeable 53 | import Data.IORef 54 | import Control.Concurrent (forkIO) 55 | import GHC.Conc (labelThread) 56 | 57 | -- | Cross between partitions. Note that this behavior requires the 58 | -- `b` class itself to encapsulate knowledge of how the partitions 59 | -- are accessed. In the normal use case, partitions are created when 60 | -- you cross into them by type, i.e. bcross into a GLUT partition in 61 | -- order to create and control a GLUT window. The illusion is that 62 | -- the partitions have always existed, they're just passive unless 63 | -- you control them - i.e. discovery, not creation. 64 | -- 65 | -- Cross from a partition to itself may optimize to identity. 66 | class BCross b where 67 | bcross :: (Partition p, Partition p') => b (S p x) (S p' x) 68 | 69 | -- | Partition p - indicates a toplevel partition type, and also 70 | -- can override the default partition thread constructor. The 71 | -- partition must return its own stopper operation, which will be 72 | -- run from within the same partition when it is time to halt the 73 | -- application. 74 | -- 75 | -- Note: Partitions are Resources (see PCX) and should not have any 76 | -- significant side-effects until some effects are demanded. 77 | -- 78 | class (Typeable p) => Partition p where 79 | -- | create a new partition thread, with access to partition 80 | -- resources via PCX. (Recommend use of GHC.Conc.labelThread.) 81 | newPartitionThread :: PCX p -> Stepper -> IO Stopper 82 | 83 | -- We need a child PCX for each partition. 84 | instance (Partition p) => Resource W (PCX p) where 85 | locateResource rp _ = newPCX rp 86 | 87 | -- | The W type represents the toplevel PCX. Each thread partition 88 | -- operates directly under the world or process level partition, W. 89 | data W 90 | 91 | -- | PSched is a partition scheduler, operating on partition threads 92 | -- in the IO monad. 93 | type PSched = Sched IO 94 | 95 | -- | Given the PCX for a partition, we can obtain the scheduler, 96 | -- though doing so is optional. See Sirea.PSched for more info. 97 | getPSched :: (Partition p) => PCX p -> IO PSched 98 | getPSched cp = 99 | findInPCX cp >>= \ tc -> 100 | getPulseScheduler cp >>= \ onPulse -> 101 | return $! Sched 102 | { stepTime = getTCTime tc 103 | , onNextStep = addTCRecv tc 104 | , onUpdPhase = addTCWork tc 105 | , onStepEnd = addTCSend tc 106 | , eventually = onPulse 107 | } 108 | 109 | -- | Pt is a type for trivial partitions. These partitions have few 110 | -- responsibilities, other than to process available RDP updates as 111 | -- fast as possible and perform specified step or pulse actions. 112 | -- 113 | -- While partitioning can be a basis for parallelism, it weakens the 114 | -- consistency properties of Sirea applications. (Within a partition 115 | -- you have determinism up to input. Across partitions, you only get 116 | -- snapshot consistency and eventual consistency. Straggling updates 117 | -- are possible if a thread falls behind.) Consider whether `bspark` 118 | -- or `bstrat` is sufficient for parallelism. 119 | -- 120 | -- Partitions are better justified when they represent resources and 121 | -- various IO responsibilities. 122 | -- 123 | data Pt x deriving(Typeable) 124 | 125 | instance (Typeable x) => Partition (Pt x) where 126 | newPartitionThread cp stepper = 127 | newIORef emptyStopData >>= \ rfStop -> 128 | forkIO (simplePartitionLoop rfStop stepper) >>= \ tid -> 129 | labelThread tid (getLabel cp) >> 130 | return (makeStopper rfStop) 131 | 132 | getLabel :: (Typeable x) => PCX x -> String 133 | getLabel = show . typeOf . getPTX 134 | where getPTX :: PCX x -> Pt x 135 | getPTX _ = undefined 136 | 137 | -- | P0 is the initial or main partition for a Sirea application. It 138 | -- has a thread, but one controlled by the Sirea client rather than 139 | -- created by Sirea. See Sirea.Build for more information. 140 | data P0 deriving(Typeable) 141 | 142 | instance Partition P0 where 143 | newPartitionThread = error "special case: main thread is not constructed" 144 | 145 | 146 | -------------------------------------------------------------------------------- /src/Sirea/Prelude.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Sirea.Prelude is a toplevel Sirea module that re-exports most 3 | -- modules, types, or specific functions a client might need from 4 | -- the basic Sirea module. 5 | module Sirea.Prelude 6 | ( module Sirea.Behavior 7 | , module Sirea.Activate 8 | , module Sirea.B 9 | , module Sirea.Partition 10 | , module Sirea.BDeep 11 | , module Sirea.Time 12 | -- * utilities 13 | , module Sirea.DemandMonitor 14 | , module Sirea.Utility 15 | , module Sirea.Clock 16 | , module Sirea.TimeTrigger 17 | , module Sirea.TimeStamp 18 | ) where 19 | 20 | import Sirea.Behavior 21 | import Sirea.BDeep 22 | import Sirea.Activate (runSireaApp) 23 | import Sirea.B (B) 24 | import Sirea.Partition (BCross(..),Partition(..), Pt, P0) 25 | import Sirea.Time (T,DT) 26 | import Sirea.DemandMonitor (bdemand, bmonitor, bactivate, bactive, bdemandl, bmonitorl) 27 | import Sirea.Utility 28 | import Sirea.Clock (bclockHours, bclockMinutes, bclockSeconds, bclockOfFreq, btickOfFreq) 29 | import Sirea.TimeTrigger (btimeTrigger) 30 | import Sirea.TimeStamp (btimeStamp, btimeStampMon) 31 | 32 | -------------------------------------------------------------------------------- /src/Sirea/Time.hs: -------------------------------------------------------------------------------- 1 | 2 | module Sirea.Time 3 | ( T 4 | , tmDay,tmNanos 5 | , mkTime,timeFromDays 6 | , getTime 7 | , DT 8 | , dtToNanos,nanosToDt 9 | , addTime,subtractTime,diffTime 10 | , fromUTC 11 | ) where 12 | 13 | import Data.Int (Int32,Int64) 14 | import Data.Ratio ((%),numerator,denominator) 15 | import qualified Data.Time.Clock as CW 16 | import qualified Data.Time.Calendar as Cal 17 | import Data.Function (on) 18 | import Control.Exception (assert) 19 | 20 | 21 | -- | T - a fixpoint representation of time UTC with nanosecond 22 | -- precision, as a pair of integers. Time in Sirea is modeled as 23 | -- continuous, but the actual implementation is limited precision. 24 | -- tmDay - Modified Julian Day (days since Nov 17, 1858) 25 | -- tmNanos - Nanoseconds in the day. [0,86400*10^9) 26 | -- Simplified. Strict. No leap seconds. Limited range, just over 27 | -- plus or minus five million years. 28 | -- 29 | -- The choice of nanoseconds is so we can squeeze time-of-day into 30 | -- a double value, for interaction with most scripting languages 31 | -- (JavaScript, most importantly). 32 | -- 33 | -- Construct via mkTime, fromUTC, or getTime. 34 | data T = T {-# UNPACK #-} !Int32 {-# UNPACK #-} !Int64 35 | deriving (Eq, Ord) 36 | 37 | _tmDay :: T -> Int32 38 | _tmDay (T d _) = d 39 | 40 | _tmNanos :: T -> Int64 41 | _tmNanos (T _ n) = n 42 | 43 | tmDay :: T -> Integer 44 | tmDay = toInteger . _tmDay 45 | 46 | tmNanos :: T -> Integer 47 | tmNanos = toInteger . _tmNanos 48 | 49 | -- | `mkTime days nanos` 50 | -- smart constructor for time 51 | mkTime :: Integer -> Integer -> T 52 | mkTime days nanos = 53 | let (q,r) = nanos `divMod` nanosInDay in 54 | let d = fromInteger (days + q) in 55 | let n = fromInteger r in 56 | T d n 57 | 58 | -- | timeFromDays will convert a Modified Julian Day, stored as a 59 | -- rational, to a T value. 60 | timeFromDays :: Rational -> T 61 | timeFromDays r = mkTime days (nanos + carry) 62 | where (days,dayFrac) = numerator r `divMod` denominator r 63 | (nanos,nanoFrac) = (dayFrac * nanosInDay) `divMod` denominator r 64 | carry = if (nanoFrac * 2 > denominator r) then 1 else 0 65 | 66 | -- | Obtain estimate of current time from operating system. 67 | getTime :: IO T 68 | getTime = CW.getCurrentTime >>= return . fromUTC 69 | 70 | fromUTC :: CW.UTCTime -> T 71 | fromUTC utc = 72 | let d = Cal.toModifiedJulianDay (CW.utctDay utc) 73 | r = toRational (CW.utctDayTime utc) 74 | n = numerator r * nanosInSec `div` denominator r 75 | in mkTime d n 76 | 77 | -- | DT - a representation of a difference in two times, accessible 78 | -- as a distance in nanoseconds. 79 | newtype DT = DT { unDT :: T } deriving (Eq, Ord) 80 | 81 | dtToNanos :: DT -> Integer 82 | dtToNanos (DT tm) = (nanosInDay * tmDay tm) + tmNanos tm 83 | 84 | nanosToDt :: Integer -> DT 85 | nanosToDt = DT . mkTime 0 86 | 87 | -- | Add a difference in time to an absolute time. 88 | addTime :: T -> DT -> T 89 | addTime (T tD tN) (DT (T dtD dtN)) = 90 | let n = tN + dtN in 91 | if (n < nnid) then T (tD + dtD) n 92 | else T (tD + dtD + 1) (n - nnid) 93 | 94 | -- | Subtract a difference in time from an absolute time 95 | subtractTime :: T -> DT -> T 96 | subtractTime tm (DT dt) = unDT (diffTime tm dt) 97 | 98 | -- | Find the difference in time, diffTime a b = a - b 99 | diffTime :: T -> T -> DT 100 | diffTime (T da na) (T db nb) = 101 | if (na < nb) then DT (T ((da - db) - 1) ((na - nb) + nnid)) 102 | else DT (T (da - db) (na - nb)) 103 | 104 | nnid :: Int64 105 | nnid = fromInteger nanosInDay 106 | 107 | nanosInDay, secondsInDay, nanosInSec :: Integer 108 | nanosInDay = secondsInDay * nanosInSec 109 | secondsInDay = 24 * 60 * 60 110 | nanosInSec = 1000 * 1000 * 1000 111 | 112 | instance Num DT where 113 | (+) (DT a) b = DT (addTime a b) 114 | (-) = diffTime `on` unDT 115 | (*) a b = nanosToDt (q + c) 116 | where na = dtToNanos a 117 | nb = dtToNanos b 118 | (q,r) = (na * nb) `divMod` nanosInSec 119 | c = if (r > (nanosInSec `div` 2)) then 1 else 0 120 | negate (DT a) = 121 | if (_tmNanos a == 0) 122 | then DT (T (negate (_tmDay a)) 0) 123 | else DT (T (negate (_tmDay a) - 1) (nnid - _tmNanos a)) 124 | abs (DT a) = if (_tmDay a < 0) then negate (DT a) else (DT a) 125 | signum (DT a) = 126 | if (_tmDay a < 0) 127 | then -1 128 | else 1 129 | fromInteger = nanosToDt . (*) nanosInSec 130 | 131 | -- 'Fractional' is primarily for the 'fromRational' 132 | -- numeric conversions in seconds. 133 | instance Fractional DT where 134 | (/) a b = nanosToDt (q + c) 135 | where na = dtToNanos a 136 | nb = dtToNanos b 137 | (q,r) = (na * nanosInSec) `divMod` nb -- 138 | c = if (2 * r > nb) then 1 else 0 -- carry 139 | recip = (1 /) 140 | fromRational rat = nanosToDt (q + c) 141 | where (q,r) = (numerator rat * nanosInSec) `divMod` denominator rat 142 | c = if (2 * r > denominator rat) then 1 else 0 143 | 144 | -- show fixpoint days and seconds 145 | instance Show T where 146 | show tm = showFrac 14 days -- 14 places for 86400s * 1000000000 ns 147 | where days = (tmDay tm * nanosInDay + tmNanos tm) % nanosInDay 148 | 149 | instance Show DT where 150 | show dt = showFrac 9 (dtToNanos dt % nanosInSec) 151 | 152 | -- represent the rational as a decimal string up to n places. 153 | -- note that rounding is necessary to restore the data precisely. 154 | showFrac :: Int -> Rational -> String 155 | showFrac nPlaces rat = 156 | assert (nPlaces > 0) $ 157 | let (sign,posR) = if (rat < 0) then ("-",negate rat) else ("",rat) in 158 | let (q,r) = numerator posR `divMod` denominator posR in 159 | let (bcarry,sFrac) = showFrac' (denominator posR) r nPlaces in 160 | let c = if bcarry then 1 else 0 in 161 | sign ++ show (q + c) ++ "." ++ sFrac 162 | 163 | showFrac' :: Integer -> Integer -> Int -> (Bool,String) 164 | showFrac' den num nPlaces = 165 | if (nPlaces == 0) then ((num*2 > den),"") else 166 | let (q,r) = (num * 10) `divMod` den in 167 | let (bc,sRem) = showFrac' den r (nPlaces - 1) in 168 | let c = if bc then 1 else 0 in 169 | let q' = c + fromInteger q in 170 | if (q' == 10) then (True, '0' : sRem) 171 | else (False, showDec q' : sRem) 172 | 173 | showDec :: Int -> Char 174 | showDec n = assert ((0 <= n) && (n <= 9)) $ toEnum (n + 48) 175 | 176 | -------------------------------------------------------------------------------- /src/Sirea/TimeStamp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | -- | TimeStamp is a simple state model to capture times associated 4 | -- with eventful observations, such as when the application starts 5 | -- or when the mouse enters a window. More precisely, TimeStamp will 6 | -- capture the start of any continuous demand for the timestamp. The 7 | -- timestamp forgets its value when the demand releases. Because it 8 | -- is naturally volatile, TimeStamp is not persisted. 9 | -- 10 | -- This is useful in conjunction with TimeTrigger to model delayed 11 | -- action, or with state models to help distinguish events such as 12 | -- button presses - by adding the timestamp. 13 | -- 14 | -- This can be used as an activity monitor with extra information on 15 | -- the start time of the activity, via btimeStampMon. 16 | -- 17 | module Sirea.TimeStamp 18 | ( btimeStamp 19 | , btimeStampMon 20 | ) where 21 | 22 | import Control.Applicative 23 | import Data.IORef 24 | import Data.Typeable 25 | import Data.Maybe (fromMaybe) 26 | import Sirea.Time 27 | import Sirea.PCX 28 | import Sirea.Partition 29 | import Sirea.UnsafeLink 30 | import Sirea.Behavior 31 | import Sirea.B 32 | import Sirea.Signal 33 | import Sirea.Internal.DemandMonitorData 34 | import Sirea.Internal.B0Impl (wrapLnEqShift, unsafeSigZipB0) 35 | import Sirea.Internal.SigType 36 | 37 | -- | Each partition can have multiple timestamps, distinguished by 38 | -- string identifiers. The `btimeStamp` behavior will both activate 39 | -- the timestamp and return its value. In case of dynamic behavior, 40 | -- it is possible to handoff the timestamp without losing its value. 41 | btimeStamp :: (Partition p) => String -> B (S p ()) (S p T) 42 | btimeStamp nm = bvoid put >>> get where 43 | put = unsafeLinkB_ (tsPut nm) 44 | get = unsafeLinkBL (tsGet nm) 45 | 46 | tsGet :: (Partition p) => String -> PCX p -> LnkUp T -> IO (LnkUp ()) 47 | tsGet nm cp lu = 48 | findByNameInPCX nm cp >>= \ ts -> 49 | newMonitorLnk (ts_md ts) lu 50 | 51 | tsPut :: (Partition p) => String -> PCX p -> IO (LnkUp ()) 52 | tsPut nm cp = 53 | findByNameInPCX nm cp >>= \ ts -> 54 | newDemandLnk (ts_da ts) 55 | 56 | -- | Passively observe the timestamp, reporting whether it is active 57 | -- and maybe the time of activity. Does not activate the timestamp. 58 | btimeStampMon :: (Partition p) => String -> B (S p ()) (S p (Maybe T)) 59 | btimeStampMon nm = bdup >>> bfirst get >>> remask where 60 | get = unsafeLinkBL (tsGet nm) 61 | remask = wrapB . const $ unsafeSigZipB0 zmon 62 | 63 | -- needed to shift `Sig T` from MonitorDist to `Sig (Maybe T)` 64 | zmon :: Sig T -> Sig () -> Sig (Maybe T) 65 | zmon sT s1 = s_mask (s_full_map Just sT) s1 66 | 67 | data TS = TS 68 | { ts_da :: !(DemandAggr () ()) 69 | , ts_md :: !(MonitorDist T) 70 | } deriving (Typeable) 71 | 72 | instance (Partition p) => Resource p TS where locateResource _ = newTS 73 | instance (Partition p) => NamedResource p TS 74 | 75 | newTS :: (Partition p) => PCX p -> IO TS 76 | newTS cp = 77 | newIORef s_never >>= \ rf -> -- memory 78 | getPSched cp >>= \ pd -> 79 | newMonitorDist pd s_never >>= \ md -> 80 | let luMon = primaryMonitorLnk md in 81 | let luTS = tsLink rf luMon in 82 | wrapLnEqShift (==) luTS >>= \ luEq -> 83 | newDemandAggr pd luEq sigActive >>= \ da -> 84 | return (TS da md) 85 | 86 | sigActive :: [Sig a] -> Sig () 87 | sigActive [] = s_never 88 | sigActive (s:ss) = s_const () $ foldl (<|>) s ss 89 | 90 | -- the link will track the values up through stability, and will use 91 | -- the current value to process the Sig () into a Sig T. 92 | tsLink :: IORef (Sig T) -> LnkUp T -> LnkUp () 93 | tsLink rf lu = LnkUp touch update idle cyc where 94 | cyc = ln_cycle lu 95 | touch = ln_touch lu 96 | idle tS = 97 | readIORef rf >>= \ s0 -> 98 | let sCln = s_trim_prior s0 (inStableT tS) in 99 | sCln `seq` writeIORef rf sCln >> 100 | ln_idle lu tS 101 | update tS tU su = 102 | readIORef rf >>= \ s0 -> 103 | let tHist = fst (s_sample_prior s0 tU) in 104 | let tCandidate = fromMaybe tU tHist in 105 | let su' = tsMap tCandidate (s_trim su tU) in 106 | let s' = s_switch s0 tU su' in 107 | let sCln = s_trim_prior s' (inStableT tS) in 108 | sCln `seq` writeIORef rf sCln >> 109 | ln_update lu tS tU su' 110 | 111 | tsMap :: T -> Sig a -> Sig T 112 | tsMap t0 (Sig (Just _) s) = t0 `seq` Sig (Just t0) (tsMapSeq1 s) 113 | tsMap _ (Sig Nothing s) = Sig Nothing (tsMapSeq0 s) 114 | 115 | -- previously active, so ignore changes from active to active. 116 | tsMapSeq1 :: Seq (Maybe a) -> Seq (Maybe T) 117 | tsMapSeq1 Done = Done 118 | tsMapSeq1 (Step _ (Just _) s) = tsMapSeq1 s 119 | tsMapSeq1 (Step tm Nothing s) = Step tm Nothing (tsMapSeq0 s) 120 | 121 | -- previously inactive, looking for next activity 122 | tsMapSeq0 :: Seq (Maybe a) -> Seq (Maybe T) 123 | tsMapSeq0 Done = Done 124 | tsMapSeq0 (Step tm (Just _) s) = Step tm (Just tm) (tsMapSeq1 s) 125 | tsMapSeq0 (Step _ Nothing s) = tsMapSeq0 s 126 | 127 | 128 | -------------------------------------------------------------------------------- /src/Sirea/TimeTrigger.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | In a reactive system, we often want to express reactions to 3 | -- time itself. A question might be "Has it been less than three 4 | -- seconds since the file was modified?" This module provides a 5 | -- precise, logical mechanism to express such queries, assuming 6 | -- you can provide a timestamp to test against: 7 | -- 8 | -- btimeTrigger :: (Partition p) => B (S p T) (S p Bool) 9 | -- 10 | -- This behavior will output True when logical time is greater than 11 | -- or equal to the time indicated in signal. The time signal will 12 | -- usually come from stateful resources (timestamp, calendar, etc.). 13 | -- The logical time is from an implicit logical clock with infinite 14 | -- precision (thus the Partition constraint), though implementation 15 | -- is expected to cheat for performance. 16 | -- 17 | module Sirea.TimeTrigger 18 | ( btimeTrigger 19 | , s_timeTrigger 20 | ) where 21 | 22 | import Sirea.B 23 | import Sirea.Time 24 | import Sirea.UnsafeLink 25 | import Sirea.Behavior 26 | import Sirea.Signal 27 | import Sirea.Partition 28 | 29 | import Sirea.Internal.SigType 30 | 31 | -- | btimeTrigger returns True whenever logical time is greater than 32 | -- or equal to the signaled time. This supports time-based triggers. 33 | -- It is more efficient and precise than use of Sirea.Clock with 34 | -- explicit comparisons. 35 | btimeTrigger :: (Partition p) => B (S p T) (S p Bool) 36 | btimeTrigger = unsafeFmapB (s_adjeqf (==) . s_timeTrigger) 37 | 38 | -- | Compute logical time trigger events on a signal. 39 | s_timeTrigger :: Sig T -> Sig Bool 40 | s_timeTrigger (Sig Nothing ts) = Sig Nothing (tt0 ts) 41 | s_timeTrigger (Sig (Just tm) ts) = Sig (Just False) (tt1 tm ts) 42 | 43 | -- tt0 - no active trigger 44 | tt0 :: Seq (Maybe T) -> Seq (Maybe Bool) 45 | tt0 Done = Done 46 | tt0 (Step t Nothing s) = Step t Nothing (tt0 s) 47 | tt0 (Step t (Just tx) s) = 48 | if (t < tx) then Step t (Just False) (tt1 tx s) 49 | else Step t (Just True) (tt0 s) 50 | 51 | -- tt1 - pending trigger 52 | tt1 :: T -> Seq (Maybe T) -> Seq (Maybe Bool) 53 | tt1 tT Done = Step tT (Just True) Done 54 | tt1 tT s@(Step t _ _) = 55 | if (tT < t) then Step tT (Just True) (tt0 s) 56 | else tt0 s 57 | 58 | 59 | -------------------------------------------------------------------------------- /src/Sirea/Trans/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses #-} 2 | 3 | -- | Error - augment a behavior with error information, which is 4 | -- merged automatically. The error information can be accessed or 5 | -- manipulated explicitly. Errors are of a single type, but we can 6 | -- exit and enter error models at will. 7 | module Sirea.Trans.Error 8 | ( ErrorB 9 | , liftError, wrapError, unwrapError 10 | , raiseError, handleError, tryInUnless, newError 11 | ) where 12 | 13 | import Prelude hiding (id,(.)) 14 | import Control.Category 15 | import Sirea.Behavior 16 | import Sirea.Partition 17 | 18 | newtype ErrorB e b x y = EB (b x (e :|: y)) 19 | 20 | -- | Wrap a behavior for the Error transform 21 | wrapError :: b x (e :|: y) -> ErrorB e b x y 22 | wrapError = EB 23 | 24 | -- | Expose the underlying behavior 25 | unwrapError :: ErrorB e b x y -> b x (e :|: y) 26 | unwrapError (EB b) = b 27 | 28 | -- | Lift an error-free behavior into the Error transform 29 | liftError :: (BSum b) => b x y -> ErrorB e b x y 30 | liftError = wrapError . (>>> binr) 31 | 32 | -- | Force an error 33 | raiseError :: (BSum b) => ErrorB e b e y 34 | raiseError = wrapError binl 35 | 36 | -- | handleError will process errors from a particular operation. 37 | handleError :: (BDisjoin b, SigInP p x) 38 | => ErrorB e b x (S p () :&: y) 39 | -> ErrorB e b (x :&: e) y 40 | -> ErrorB e b x y 41 | handleError b0 bF = tryInUnless b0 (liftError bsnd) bF 42 | 43 | -- | Try to catch errors raised by a primary comptuation. 44 | -- 45 | -- This offers a lot more context than handleError. It is a somewhat 46 | -- awkward construct, but is borrowed from the arrows package. 47 | -- 48 | tryInUnless :: (BDisjoin b, SigInP p x) 49 | => ErrorB e b x (S p () :&: y) -- computation with errors 50 | -> ErrorB e b (x :&: y) z -- on success 51 | -> ErrorB e b (x :&: e) z -- on failure 52 | -> ErrorB e b x z 53 | tryInUnless (EB b0) (EB bS) (EB bF) = wrapError $ 54 | bdup >>> bsecond b0 >>> -- @ (x :&: (e :|: (S p () :&: y))) 55 | bsecond bmirror >>> bdisjoin >>> -- @ ((x :&: y) :|: (x :&: e)) 56 | (bS +++ bF) >>> bmerge -- @ (e :|: z) 57 | 58 | -- | newError makes errors associated with an operation observable 59 | newError :: (BSum b) => ErrorB e b x y -> ErrorB e b x (e :|: y) 60 | newError = liftError . unwrapError 61 | 62 | instance (BSum b) => Category (ErrorB e b) where 63 | id = liftError id 64 | (EB g) . (EB f) = EB $ 65 | f >>> bright g >>> bassocls >>> bleft bmerge 66 | 67 | instance (BSum b, BFmap b) => BFmap (ErrorB e b) where 68 | bfmap = liftError . bfmap 69 | bconst = liftError . bconst 70 | bstrat = liftError bstrat 71 | btouch = liftError btouch 72 | badjeqf = liftError badjeqf 73 | instance (BSum b) => BSum (ErrorB e b) where 74 | bleft (EB f) = EB $ bleft f >>> bassocrs 75 | bmirror = liftError bmirror 76 | bmerge = liftError bmerge 77 | b0i = liftError b0i 78 | b0e = liftError b0e 79 | bvacuous= liftError bvacuous 80 | bassocls= liftError bassocls 81 | instance (BSplit b) => BSplit (ErrorB e b) where 82 | bsplit = liftError bsplit 83 | instance (BTemporal b, BSum b) => BTemporal (ErrorB e b) where 84 | bdelay = liftError . bdelay 85 | bsynch = liftError bsynch 86 | 87 | -- from Sirea.Partition 88 | instance (BCross b, BSum b) => BCross (ErrorB e b) where 89 | bcross = liftError bcross 90 | 91 | 92 | -- BProd seems to be infeasible. Basically, the issue is that I 93 | -- cannot model `bfirst` without a disjoin, and I cannot model a 94 | -- disjoin for a generic type. So, ErrorB is not a product behavior. 95 | -- 96 | --instance (BProd b, BSum b) => BProd (ErrorB e b) where 97 | -- bfirst (EB f) = 98 | -- ALSO BLOCKS: BDisjoin, BZip, Behavior, BDynamic 99 | 100 | 101 | 102 | 103 | 104 | -------------------------------------------------------------------------------- /src/Sirea/Trans/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | -- | PureB - restrict a behavior to the pure subset. PureB does not 4 | -- export a `wrap` function, thus developers cannot inject effectful 5 | -- behaviors into PureB. Instead, one can only compose or unwrap a 6 | -- pure behavior. 7 | -- 8 | -- The advantage of pure behaviors over just using Haskell functions 9 | -- is their ability to model distribution, delay, synchronization, 10 | -- and independent update of complex signals. `beval` and `bcross` 11 | -- are both accessible for pure behaviors. 12 | -- 13 | module Sirea.Trans.Pure 14 | ( PureB, unwrapPure 15 | ) where 16 | 17 | import Prelude hiding (id,(.)) 18 | import Control.Category 19 | import Sirea.Behavior 20 | import Sirea.Partition 21 | 22 | -- | PureB is a behavior that has no side-effects and no access to 23 | -- external resources. This can be useful to enforce purity on RDP 24 | -- subprograms, e.g. to isolate a dynamic behavior. 25 | newtype PureB b x y = PB (b x y) 26 | 27 | liftPure :: b x y -> PureB b x y 28 | liftPure = PB 29 | 30 | -- | Pure behaviors can be unwrapped and treated as impure behaviors 31 | unwrapPure :: PureB b x y -> b x y 32 | unwrapPure (PB f) = f 33 | 34 | -- from Sirea.Behavior 35 | instance (Category b) => Category (PureB b) where 36 | id = liftPure id 37 | (PB f) . (PB g) = PB (f . g) 38 | instance (BFmap b) => BFmap (PureB b) where 39 | bfmap = liftPure . bfmap 40 | bconst = liftPure . bconst 41 | bstrat = liftPure bstrat 42 | btouch = liftPure btouch 43 | badjeqf = liftPure badjeqf 44 | instance (BProd b) => BProd (PureB b) where 45 | bfirst (PB f) = PB (bfirst f) 46 | bdup = liftPure bdup 47 | b1i = liftPure b1i 48 | b1e = liftPure b1e 49 | btrivial= liftPure btrivial 50 | bswap = liftPure bswap 51 | bassoclp= liftPure bassoclp 52 | instance (BSum b) => BSum (PureB b) where 53 | bleft (PB f) = PB (bleft f) 54 | bmirror = liftPure bmirror 55 | bmerge = liftPure bmerge 56 | b0i = liftPure b0i 57 | b0e = liftPure b0e 58 | bvacuous= liftPure bvacuous 59 | bassocls= liftPure bassocls 60 | instance (BDisjoin b) => BDisjoin (PureB b) where 61 | bdisjoin= liftPure bdisjoin 62 | instance (BZip b) => BZip (PureB b) where 63 | bzap = liftPure bzap 64 | instance (BSplit b) => BSplit (PureB b) where 65 | bsplit = liftPure bsplit 66 | instance (BTemporal b) => BTemporal (PureB b) where 67 | bdelay = liftPure . bdelay 68 | bsynch = liftPure bsynch 69 | instance (Behavior b) => Behavior (PureB b) 70 | 71 | instance (BDynamic b b') => BDynamic b (PureB b') where 72 | bevalx bdt = bfirst (bfmap unwrapPure) >>> bevalx (unwrapPure bdt) 73 | bexec = bfirst (bfmap unwrapPure) >>> bexec 74 | instance (BDynamic b b') => BDynamic (PureB b) (PureB b') where 75 | bevalx = liftPure . bevalx 76 | bexec = liftPure bexec 77 | 78 | -- from Sirea.Partition 79 | instance (BCross b) => BCross (PureB b) where 80 | bcross = liftPure bcross 81 | 82 | 83 | 84 | 85 | 86 | 87 | -------------------------------------------------------------------------------- /src/Sirea/Trans/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | 4 | module Sirea.Trans.Reader 5 | ( ReaderB 6 | , liftReader, wrapReader, unwrapReader 7 | ) where 8 | 9 | import Prelude hiding (id,(.)) 10 | import Control.Category 11 | import Sirea.Behavior 12 | import Sirea.Partition 13 | 14 | 15 | newtype ReaderB r b x y = RB (b (r :&: x) y) 16 | 17 | wrapReader :: b (r :&: x) y -> ReaderB r b x y 18 | wrapReader = RB 19 | 20 | unwrapReader :: ReaderB r b x y -> b (r :&: x) y 21 | unwrapReader (RB b) = b 22 | 23 | liftReader :: (BProd b) => b x y -> ReaderB r b x y 24 | liftReader = wrapReader . (bsnd >>>) 25 | 26 | -- from Sirea.Behavior 27 | instance (BProd b) => Category (ReaderB r b) where 28 | id = liftReader id 29 | (RB g) . (RB f) = RB $ 30 | bfirst bdup >>> bassocrp >>> bsecond f >>> g 31 | instance (BFmap b, BProd b) => BFmap (ReaderB r b) where 32 | bfmap = liftReader . bfmap 33 | bconst = liftReader . bconst 34 | bstrat = liftReader bstrat 35 | btouch = liftReader btouch 36 | badjeqf = liftReader badjeqf 37 | instance (BProd b) => BProd (ReaderB r b) where 38 | -- bfirst :: (r :&: (x :&: y)) ~> (x' :&: y) 39 | bfirst (RB f) = RB $ bassoclp >>> bfirst f 40 | bdup = liftReader bdup 41 | b1i = liftReader b1i 42 | b1e = liftReader b1e 43 | btrivial= liftReader btrivial 44 | bswap = liftReader bswap 45 | bassoclp= liftReader bassoclp 46 | instance (BZip b) => BZip (ReaderB r b) where 47 | bzap = liftReader bzap 48 | instance (BProd b, BTemporal b) => BTemporal (ReaderB r b) where 49 | bdelay = liftReader . bdelay 50 | bsynch = liftReader bsynch 51 | 52 | -- from Sirea.Partition 53 | instance (BProd b, BCross b) => BCross (ReaderB r b) where 54 | bcross = liftReader bcross 55 | 56 | 57 | -- Note: BSum is not supported for ReaderB due to a general inability 58 | -- to disjoin to apply bleft. This also blocks BSplit, BDisjoin, BDynamic, 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /src/Sirea/Trans/Static.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | -- | Static - augment a behavior with static information, applying an 4 | -- applicative when building the behavior. 5 | -- 6 | -- This is probably the most useful basis for behavior transforms in 7 | -- RDP, e.g. for configuration and dependency injection, and staged 8 | -- programming. 9 | module Sirea.Trans.Static 10 | ( StaticB 11 | , liftStatic, wrapStatic, unwrapStatic 12 | ) where 13 | 14 | import Prelude hiding (id,(.)) 15 | import Control.Category 16 | import Control.Applicative 17 | import Sirea.Behavior 18 | import Sirea.Partition 19 | 20 | -- | StaticB is a behavior built by an applicative. 21 | newtype StaticB f b x y = SB (f (b x y)) 22 | 23 | wrapStatic :: f (b x y) -> StaticB f b x y 24 | wrapStatic = SB 25 | 26 | unwrapStatic :: StaticB f b x y -> f (b x y) 27 | unwrapStatic (SB fbxy) = fbxy 28 | 29 | liftStatic :: (Applicative f) => b x y -> StaticB f b x y 30 | liftStatic = SB . pure 31 | 32 | -- from Sirea.Behavior 33 | instance (Category b, Applicative f) => Category (StaticB f b) where 34 | id = liftStatic id 35 | (SB f) . (SB g) = SB $ (.) <$> f <*> g 36 | instance (BFmap b, Applicative f) => BFmap (StaticB f b) where 37 | bfmap = liftStatic . bfmap 38 | bconst = liftStatic . bconst 39 | bstrat = liftStatic bstrat 40 | btouch = liftStatic btouch 41 | badjeqf = liftStatic badjeqf 42 | instance (BProd b, Applicative f) => BProd (StaticB f b) where 43 | bfirst (SB f) = SB (bfirst <$> f) 44 | bdup = liftStatic bdup 45 | b1i = liftStatic b1i 46 | b1e = liftStatic b1e 47 | btrivial= liftStatic btrivial 48 | bswap = liftStatic bswap 49 | bassoclp= liftStatic bassoclp 50 | instance (BSum b, Applicative f) => BSum (StaticB f b) where 51 | bleft (SB f) = SB (bleft <$> f) 52 | bmirror = liftStatic bmirror 53 | bmerge = liftStatic bmerge 54 | b0i = liftStatic b0i 55 | b0e = liftStatic b0e 56 | bvacuous= liftStatic bvacuous 57 | bassocls= liftStatic bassocls 58 | instance (BDisjoin b, Applicative f) => BDisjoin (StaticB f b) where 59 | bdisjoin= liftStatic bdisjoin 60 | instance (BZip b, Applicative f) => BZip (StaticB f b) where 61 | bzap = liftStatic bzap 62 | instance (BSplit b, Applicative f) => BSplit (StaticB f b) where 63 | bsplit = liftStatic bsplit 64 | instance (BTemporal b, Applicative f) => BTemporal (StaticB f b) where 65 | bdelay = liftStatic . bdelay 66 | bsynch = liftStatic bsynch 67 | instance (Behavior b, Applicative f) => Behavior (StaticB f b) 68 | 69 | -- Static cannot evaluate itself, in general, but may evaluate any 70 | -- dynamic behavior that the original behavior could evaluate. 71 | instance (BDynamic b b', Applicative f) => BDynamic (StaticB f b) b' where 72 | bevalx = liftStatic . bevalx 73 | bexec = liftStatic bexec 74 | 75 | -- from Sirea.Partition 76 | instance (BCross b, Applicative f) => BCross (StaticB f b) where 77 | bcross = liftStatic bcross 78 | 79 | 80 | 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /src/Sirea/UnsafeIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GADTs #-} 2 | 3 | -- | UnsafeIO provides a few quick and dirty behaviors to integrate 4 | -- Haskell IO with Sirea. These are 'unsafe' in the sense that they 5 | -- can violate RDP's invariants if not used carefully, but they are 6 | -- safe with respect to Haskell's IO monad (no unsafePerformIO). 7 | -- 8 | -- Haskell IO in Sirea is rarely idempotent or commutative, and has 9 | -- poor support for speculation, increasing latencies and rework. In 10 | -- Sirea, it is essential to avoid blocking IO within a partition. 11 | -- And sequential operations might not interleave the way one might 12 | -- expect (due to bursty and non-deterministic stability updates). 13 | -- 14 | -- This module supports currently supports one IO adapter model, in 15 | -- a few variations: 16 | -- 17 | -- OnUpdate - perform output action whenever input signal changes. 18 | -- 19 | -- Eventually, I would like to support more models for ease of use: 20 | -- 21 | -- ReadOnce - perform input action when input changes. 22 | -- perhaps some minimal support for speculation. 23 | -- OnEvents - ReadOnce + schedule reads via event API. 24 | -- IOPolled - perform ad-hoc actions as stability updates. 25 | -- IOAction - fusion of OnUpdate and Polled. 26 | -- 27 | -- AgentResource and PCX may help lift these into proper APIs. 28 | -- 29 | module Sirea.UnsafeIO 30 | ( unsafeOnUpdateB 31 | , unsafeOnUpdateBL 32 | , unsafeOnUpdateBLN 33 | ) where 34 | 35 | import Data.IORef 36 | import Control.Exception (assert) 37 | import Sirea.UnsafeLink 38 | import Sirea.Signal 39 | import Sirea.Time 40 | import Sirea.Behavior 41 | import Sirea.B 42 | import Sirea.PCX 43 | import Sirea.Partition 44 | import Sirea.Internal.Tuning (tAncient) 45 | 46 | -- | unsafeOnUpdateB - perform an IO action for every unique value 47 | -- in a signal as it becomes stable, then forward the update. There 48 | -- is also a one-time IO action on initial construction. 49 | unsafeOnUpdateB :: (Eq a, Partition p) 50 | => (PCX p -> IO (T -> a -> IO ())) 51 | -> B (S p a) (S p a) 52 | unsafeOnUpdateB = unsafeLinkB . mkOnUpdate 53 | 54 | -- | unsafeOnUpdateBL - a variation of unsafeOnUpdateB that does not 55 | -- prevent dead-code elimination. The behavior will be dropped if 56 | -- the `S p a` signal is not used downstream. 57 | unsafeOnUpdateBL :: (Eq a, Partition p) 58 | => (PCX p -> IO (T -> a -> IO ())) 59 | -> B (S p a) (S p a) 60 | unsafeOnUpdateBL = unsafeLinkBL . mkOnUpdate 61 | 62 | -- | unsafeOnUpdateBLN - perform IO effects on the first signal if 63 | -- any of the signals are used in the pipeline. This is useful to 64 | -- debug a behavior without preventing dead-code elimination. 65 | unsafeOnUpdateBLN :: (Eq a, Partition p) 66 | => (PCX p -> IO (T -> a -> IO ())) 67 | -> B (S p a :&: x) (S p a :&: x) 68 | unsafeOnUpdateBLN = unsafeLinkBLN . mkOnUpdate 69 | 70 | mkOnUpdate :: (Eq a, Partition p) 71 | => (PCX p -> IO (T -> a -> IO ())) 72 | -> PCX p -> LnkUp a -> IO (LnkUp a) 73 | mkOnUpdate mkOp cp lu = 74 | mkOp cp >>= \ op -> 75 | newIORef (P s_never (StableT tAncient)) >>= \ rfSig -> 76 | let lu' = luOnUpdate op rfSig lu in 77 | return lu' 78 | 79 | -- simple strict pair 80 | -- 81 | -- The recorded signal actually includes some values from before the 82 | -- StableT value such that we can filter duplicates. No other record 83 | -- of signal history is needed. 84 | data P z = P !(Sig z) {-# UNPACK #-} !StableT 85 | 86 | luOnUpdate :: (Eq a) 87 | => (T -> a -> IO ()) -- operation to execute 88 | -> IORef (P a) -- recorded signal; reported time 89 | -> LnkUp a -- output sink (just forward input, but AFTER running) 90 | -> LnkUp a -- input source 91 | luOnUpdate op rfSig lu = LnkUp touch update idle cyc where 92 | touch = ln_touch lu 93 | cyc = ln_cycle lu 94 | idle tS = 95 | readIORef rfSig >>= \ (P s0 tS0) -> 96 | runUpdates tS0 tS s0 >> 97 | ln_idle lu tS 98 | update tS tU su = 99 | readIORef rfSig >>= \ (P s0 tS0) -> 100 | assert (tU >= inStableT tS0) $ 101 | let s' = s_switch' s0 tU su in 102 | runUpdates tS0 tS s' >> 103 | ln_update lu tS tU su 104 | lessOneNano tm = tm `subtractTime` nanosToDt 1 105 | record tS sig = 106 | let p = P sig tS in 107 | p `seq` writeIORef rfSig p 108 | runUpdates tS0 tS s = 109 | assert (tS >= tS0) $ 110 | if (tS0 == tS) then record tS s else 111 | let tLo = inStableT tS0 in 112 | let tLoR = lessOneNano tLo in -- for equality filter 113 | let tHi = inStableT tS in 114 | let sGC = s_trim s (lessOneNano tHi) in 115 | record tS sGC >> 116 | let ops = takeWhile ((< tHi) . fst) $ 117 | dropWhile ((< tLo) . fst) $ 118 | sigToList (s_adjeqf (==) s) tLoR tHi 119 | in 120 | mapM_ runOp ops 121 | runOp (a,Just b) = op a b 122 | runOp _ = return () 123 | 124 | {- 125 | -- | unsafeReadOnceB is suitable for resources that are constant or 126 | -- can reasonably be assumed constant. Such resources are rare, but 127 | -- do exist (e.g. environment variables). One-time construction can 128 | -- support caches and similar. 129 | -- 130 | -- Note: unsafeReadOnce is lazy. It will not execute if there is no 131 | -- consumer for the generated value. It also runs in the middle of a 132 | -- step, so there should be no assumptions about whether updates are 133 | -- consistent. 134 | unsafeReadOnceB :: (Eq a, Partition p) 135 | => (PCX p -> IO (T -> a -> IO b)) 136 | -> B (S p a) (S p b) 137 | unsafeReadOnceB = unsafeOnEventsB . const 138 | 139 | -- | unsafeReadOnceBI 140 | 141 | 142 | -- | unsafeOnEventsB allows a reader to hook a simple events API. 143 | -- This is exactly the same as unsafeReadOnceB, except that a notify 144 | -- operation is provided. The notify operation informs Sirea that 145 | -- more should be read for a given time. Notification is idempotent, 146 | -- and accumulative. 147 | 148 | -} 149 | 150 | 151 | 152 | 153 | -------------------------------------------------------------------------------- /src/Sirea/UnsafeLink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GADTs #-} 2 | 3 | -- | Simple support for new behavior primitives in Sirea, requires 4 | -- the processing be isolated to one signal. 5 | -- 6 | -- These shouldn't be necessary often, since it will only take a few 7 | -- common abstractions to support most new ideas and resources. But 8 | -- unsafeLinkB ensures that unforseen corner cases can be handled. 9 | -- 10 | -- Processing multiple signals will require deeper access to Sirea's 11 | -- representations. 12 | -- 13 | module Sirea.UnsafeLink 14 | ( unsafeFmapB 15 | , unsafeLinkB, unsafeLinkB_, unsafeLinkBL, unsafeLinkBLN 16 | , unsafeLinkWB, unsafeLinkWB_, unsafeLinkWBL, unsafeLinkWBLN 17 | , LnkUpM(..), LnkUp, StableT(..), inStableT 18 | , ln_zero, ln_sfmap, ln_lumap, ln_append 19 | ) where 20 | 21 | import Data.Function (fix) 22 | import Control.Applicative 23 | import Control.Exception (assert) 24 | import Sirea.Internal.LTypes 25 | import Sirea.Internal.B0Impl (mkLnkB0, mkLnkPure, forceDelayB0 26 | ,undeadB0, keepAliveB0) 27 | import Sirea.Internal.B0 28 | import Sirea.Behavior 29 | import Sirea.Signal 30 | import Sirea.B 31 | import Sirea.PCX 32 | import Sirea.Partition (W, Partition) 33 | 34 | -- | pure signal transforms, but might not respect RDP invariants. 35 | unsafeFmapB :: (Sig a -> Sig b) -> B (S p a) (S p b) 36 | unsafeFmapB = wrapB . const . unsafeFmapB0 37 | 38 | unsafeFmapB0 :: (Monad m) => (Sig a -> Sig b) -> B0 m (S p a) (S p b) 39 | unsafeFmapB0 = mkLnkPure lc_fwd . ln_lumap . ln_sfmap 40 | 41 | lpcx1 :: (Partition p) => B (S p x) z -> PCX W -> IO (PCX p) 42 | lpcx1 _ = findInPCX 43 | 44 | lpcx2 :: (Partition p) => B (S p x :&: y) z -> PCX W -> IO (PCX p) 45 | lpcx2 _ = findInPCX 46 | 47 | 48 | -- | unsafeLinkB is used when the link has some side-effects other 49 | -- than processing the signal, and thus needs to receive a signal 50 | -- even if it is not going to pass one on. 51 | unsafeLinkB :: (Partition p) => (PCX p -> LnkUp y -> IO (LnkUp x)) -> B (S p x) (S p y) 52 | unsafeLinkB fn = fix $ unsafeLinkWB . fn' where 53 | fn' b cw lu = lpcx1 b cw >>= \ cp -> fn cp lu 54 | 55 | -- | unsafeLinkB_ describes a sink, cases where the response signal 56 | -- is unused. Usually, this is used by wrapping it with `bvoid`. 57 | unsafeLinkB_ :: (Partition p) => (PCX p -> IO (LnkUp x)) -> B (S p x) S1 58 | unsafeLinkB_ fn = fix $ unsafeLinkWB_ . fn' where 59 | fn' b cw = lpcx1 b cw >>= fn 60 | 61 | -- | unsafeLinkBL is the lazy form of unsafeLinkB; it is inactive 62 | -- unless the response signal is necessary downstream. 63 | unsafeLinkBL :: (Partition p) => (PCX p -> LnkUp y -> IO (LnkUp x)) -> B (S p x) (S p y) 64 | unsafeLinkBL fn = fix $ unsafeLinkWBL . fn' where 65 | fn' b cw lu = lpcx1 b cw >>= \ cp -> fn cp lu 66 | 67 | -- | unsafeLinkBLN is a semi-lazy form of unsafeLinkB; it is active 68 | -- if any of the input signals are needed downstream, but operates 69 | -- only on the first input (even if its particular output is not 70 | -- used downstream). 71 | unsafeLinkBLN :: (Partition p) => (PCX p -> LnkUp y -> IO (LnkUp x)) -> B (S p x :&: z) (S p y :&: z) 72 | unsafeLinkBLN fn = fix $ unsafeLinkWBLN . fn' where 73 | fn' b cw lu = lpcx2 b cw >>= \ cp -> fn cp lu 74 | 75 | -- | same as unsafeLinkB, but with world context 76 | unsafeLinkWB :: (PCX W -> LnkUp y -> IO (LnkUp x)) -> B (S p x) (S p y) 77 | unsafeLinkWB fn = unsafeLinkWBL fn >>> (wrapB . const) undeadB0 78 | 79 | -- | same as unsafeLinkB_, but with world context 80 | unsafeLinkWB_ :: (PCX W -> IO (LnkUp x)) -> B (S p x) S1 81 | unsafeLinkWB_ fn = wrapB b0 where 82 | b0 cw = forceDelayB0 >>> mkLnkB0 lc_dupCaps (ul cw) 83 | ul cw _ ln = assert (ln_dead ln) $ LnkSig <$> fn cw 84 | 85 | -- | same as unsafeLinkBL, but with world context 86 | unsafeLinkWBL :: (PCX W -> LnkUp y -> IO (LnkUp x)) -> B (S p x) (S p y) 87 | unsafeLinkWBL fn = wrapB b0 where 88 | b0 cw = forceDelayB0 >>> mkLnkB0 lc_fwd (ul cw) 89 | ul cw _ (LnkSig lu) = LnkSig <$> fn cw lu 90 | ul _ _ LnkDead = return LnkDead 91 | 92 | -- | same as unsafeLinkBLN, but with world context 93 | unsafeLinkWBLN :: (PCX W -> LnkUp y -> IO (LnkUp x)) -> B (S p x :&: z) (S p y :&: z) 94 | unsafeLinkWBLN fn = bfirst (unsafeLinkWBL fn) >>> (wrapB . const) keepAliveB0 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /src/Sirea/Utility.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeOperators, GADTs #-} 2 | 3 | -- | Utility behaviors that lack a better home. 4 | module Sirea.Utility 5 | ( bprint, bprintWith 6 | , biofmap, bioconst 7 | , bundefined 8 | ) where 9 | 10 | import Sirea.Behavior 11 | import Sirea.B 12 | import Sirea.Internal.B0 13 | import Sirea.Internal.B0Impl 14 | import Sirea.Internal.LTypes 15 | import Sirea.Partition (P0) 16 | import Sirea.UnsafeIO 17 | import Sirea.AgentResource 18 | import Sirea.DemandMonitor 19 | import Sirea.Signal 20 | import Sirea.UnsafeLink 21 | import Sirea.PCX 22 | import Sirea.Time (T) 23 | import Data.IORef 24 | import Data.Maybe (isNothing) 25 | import Data.Typeable 26 | import qualified Data.Set as S 27 | import Control.Monad (unless) 28 | import Control.Exception (assert) 29 | import Control.Applicative 30 | 31 | {- IDEA: a more useful, more declarative console? 32 | Rejected: Console input isn't suitable for persistent, reactive 33 | models like Sirea. A user-input file is much more promising as 34 | primitive input models go, and more broadly useful for configs. 35 | -} 36 | 37 | {- TODO: a TimeStamp state behavior: 38 | String -> B (S p ()) (S p T) 39 | Returns a timestamp for the start of a period of contiguous activity. 40 | Inherently volatile. No need for persistence. 41 | -} 42 | 43 | -- | Print lines to the console or standard output. Demand to print 44 | -- a line will cause it to be printed (if the demand stabilizes). 45 | -- Continuous demand results in a line being printed only once. If 46 | -- multiple clients need the printer concurrently, then concurrent 47 | -- lines for an instant will be printed in lexicographic order. 48 | -- 49 | -- bprint = bprintWith show 50 | -- 51 | bprint :: (Show a) => B (S P0 a) (S P0 a) 52 | bprint = bprintWith show 53 | 54 | -- | Provide your own show function for printing. 55 | bprintWith :: (a -> String) -> B (S P0 a) (S P0 a) 56 | bprintWith fn = publish |*| invoke where 57 | publish = bfmap fn >>> fst printDeMon 58 | invoke = bfmap (const ()) >>> unsafeInvokeAgent (Printer ()) 59 | printDeMon :: DemandMonitor B P0 String (S.Set String) 60 | printDeMon = demandMonitor "console" 61 | 62 | newtype Printer = Printer () deriving (Typeable) 63 | instance AgentBehavior P0 Printer where 64 | agentBehaviorSpec _ = getLines >>> printLines >>> btrivial where 65 | getLines = snd printDeMon 66 | printLines = unsafeOnUpdateB mkPrinter 67 | newtype PrintMem = PrintMem { inPrintMem :: IORef (S.Set String) } 68 | deriving (Typeable) 69 | instance Resource P0 PrintMem where 70 | locateResource _ _ = PrintMem <$> newIORef S.empty 71 | 72 | mkPrinter :: PCX P0 -> IO (T -> S.Set String -> IO ()) 73 | mkPrinter cp = findInPCX cp >>= return . doPrint . inPrintMem where 74 | doPrint rf _ ss = 75 | readIORef rf >>= \ ss0 -> 76 | writeIORef rf ss >> 77 | mapM_ putStrLn (S.toAscList (S.difference ss ss0)) 78 | 79 | -- | bioconst - Obtain a constant value using one-time IO. Might be 80 | -- suitable for environment variables or similar. 81 | -- 82 | -- The IO operation should be idempotent, returning the same value 83 | -- on different calls. It should be 'safe' in the sense that it is 84 | -- not a problem if it is not called if the value is unnecessary. In 85 | -- particular, newUnique, newIORef, and the like are not compatible 86 | -- with RDP's assumptions about internal identity or state, and will 87 | -- not behave robustly in dynamic behaviors or across restarts. 88 | -- 89 | bioconst :: IO c -> B (S p ()) (S p c) 90 | bioconst mkC = unsafeLinkWBL mkConst where 91 | mkConst _ lnc = 92 | mkC >>= \ c -> 93 | return (ln_sfmap (s_const c) lnc) 94 | 95 | -- | biofmap - Obtain a pure function using one-time IO. See notes 96 | -- for bioconst. This is much less likely to see use than bioconst. 97 | biofmap :: IO (a -> b) -> B (S p a) (S p b) 98 | biofmap mkF = unsafeLinkWBL mkFmap where 99 | mkFmap _ lnb = 100 | mkF >>= \ f -> 101 | return (ln_sfmap (s_fmap f) lnb) 102 | 103 | -- | bundefined - exploratory programming often involves incomplete 104 | -- behaviors. `bundefined` serves a similar role to `undefined` in 105 | -- pure Haskell functions, but can work within RDP's compilation and 106 | -- anticipation framework. 107 | bundefined :: (SigInP p y) => B (S p x) y 108 | bundefined = bfmap (const ()) >>> undefinedB 109 | 110 | -- might be nice to put some equivalent to 'assert' here, too. 111 | 112 | -- undefinedB is only live code if there is demand on `y`. 113 | -- This would be unsafe without `y` being entirely in p. 114 | -- 115 | -- Here `undefinedB` fails if it ever stabilizes on an active input 116 | -- signal, but can accept temporary activity so long as it's in the 117 | -- unstable future. 118 | -- 119 | -- undefinedB might be eliminated unless there is a valid consumer 120 | -- of the signal downstream. 121 | -- 122 | undefinedB :: (SigInP p y) => B (S p ()) y 123 | undefinedB = unsafeLinkWBL (const mkTestActivity) >>> 124 | (wrapB . const) nullB0 125 | 126 | mkTestActivity :: LnkUp () -> IO (LnkUp ()) 127 | mkTestActivity lu = 128 | newIORef st_zero >>= \ rf -> 129 | return (testActivity rf lu) 130 | 131 | testActivity :: IORef (SigSt ()) -> LnkUp () -> LnkUp () 132 | testActivity rf lu = LnkUp touch update idle cyc where 133 | touch = ln_touch lu 134 | cyc = ln_cycle lu 135 | idle tS = 136 | process (st_idle tS) >> 137 | ln_idle lu tS 138 | update tS tU su = 139 | process (st_update tS tU su) >> 140 | ln_update lu tS tU su 141 | process fn = 142 | readIORef rf >>= \ st0 -> 143 | let st = fn st0 in 144 | let stCln = st_clear (st_stable st) st in 145 | stCln `seq` writeIORef rf stCln >> 146 | runTest (st_stable st0) (st_stable st) (st_signal st) 147 | runTest (StableT t0) (StableT tf) sig = 148 | assert (tf >= t0) $ 149 | let lSigs = takeWhile ((< tf) . fst) $ sigToList sig t0 tf in 150 | let bInactive = all (isNothing . snd) lSigs in 151 | unless bInactive $ 152 | fail "undefined behavior activated" 153 | 154 | -- nullB0 will idle instead of update, promising inactivity to all 155 | -- downstream components. Since undefinedB will fail before this 156 | -- promise is ever broken, it's actually a valid promise. 157 | nullB0 :: (Monad m, SigInP p y) => B0 m (S p ()) y 158 | nullB0 = mkLnkB0 lc_dupCaps (const (return . sendNothing)) 159 | 160 | -- undefinedB is a bit more sophisticated than just dropping signal. 161 | -- Instead, it forwards an idling operation to downstream clients. 162 | sendNothing :: (Monad m) => LnkM m y -> LnkM m (S p ()) 163 | sendNothing LnkDead = LnkDead 164 | sendNothing (LnkProd x y) = (sendNothing x) `lnPlus` (sendNothing y) 165 | sendNothing (LnkSum x y) = (sendNothing x) `lnPlus` (sendNothing y) 166 | sendNothing (LnkSig lu) = LnkSig (LnkUp touch update idle cyc) where 167 | touch = ln_touch lu 168 | update tS _ _ = ln_idle lu tS 169 | idle = ln_idle lu 170 | cyc = ln_cycle lu 171 | 172 | lnPlus :: (Monad m) => LnkM m (S p a) -> LnkM m (S p a) -> LnkM m (S p a) 173 | lnPlus LnkDead y = y 174 | lnPlus x LnkDead = x 175 | lnPlus x y = LnkSig (ln_lnkup x `ln_append` ln_lnkup y) 176 | 177 | 178 | -------------------------------------------------------------------------------- /tst/Clock.hs: -------------------------------------------------------------------------------- 1 | -- clock (on console, for now) 2 | -- todo: add a UI clock. 3 | module Main 4 | ( main 5 | ) where 6 | 7 | import Sirea.Prelude 8 | import Sirea.Clock 9 | import Sirea.Time 10 | import Control.Exception (assert) 11 | 12 | -- a better way to show the clock... 13 | timeString :: T -> String 14 | timeString t = 15 | let nDay = tmNanos t in 16 | let sDay = nDay `div` 1000000000 in 17 | let (mDay,s) = sDay `divMod` 60 in 18 | let (hDay,m) = mDay `divMod` 60 in 19 | s2 hDay ++ ":" ++ s2 m ++ ":" ++ s2 s 20 | where s2 x = assert ((x >= 0) && (x < 100)) $ 21 | if x < 10 22 | then "0" ++ show x 23 | else show x 24 | 25 | -- using clock, printing based on stability. (Only works for low rate 26 | -- clocks... up to ~20Hz. Higher rate will update in bursts.) 27 | bCC :: B (S P0 ()) (S P0 ()) 28 | bCC = bvoid $ bclockSeconds >>> bseq >>> bprintWith timeString 29 | 30 | main :: IO () 31 | main = 32 | print "before clock app" >> 33 | runSireaApp bCC >> 34 | print "after clock app" 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /tst/Cyc.hs: -------------------------------------------------------------------------------- 1 | -- some tests for behaviors. 2 | {-# LANGUAGE TypeOperators #-} 3 | module Main 4 | ( main 5 | ) where 6 | 7 | import Sirea.Prelude 8 | import Sirea.UnsafeLink 9 | import Sirea.UnsafeIO 10 | import Sirea.Clock 11 | import Sirea.Time 12 | import Sirea.DemandMonitor 13 | import Control.Monad (unless) 14 | import qualified Data.Set as S 15 | import Debug.Trace 16 | 17 | main :: IO () 18 | main = runSireaApp $ tstCycle |*| (bconst (int 0) >>> bdemand dm) 19 | 20 | dm :: String 21 | dm = "TestCycle" 22 | 23 | tstCycle :: B (S P0 ()) (S P0 ()) 24 | tstCycle = bmonitor dm >>> bdelay 0.1 >>> bfmap addOne >>> bprint >>> bdemand dm 25 | where addOne = succ . S.findMax . S.insert (minBound :: Int) 26 | 27 | -- 'int' is just a type annotation to help inference 28 | int :: Int -> Int 29 | int = id 30 | 31 | -------------------------------------------------------------------------------- /tst/Fibonacci.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | -- | Test that computes fibonacci values in a naive, recursive manner 4 | -- using RDP structure. This is more a proof-of-ability and a test for 5 | -- dynamic behaviors. Dynamic behaviors should be used sparingly in 6 | -- practical RDP. 7 | module Main 8 | ( main 9 | ) where 10 | 11 | import Sirea.Prelude 12 | import Sirea.Clock 13 | import Sirea.Time 14 | 15 | fib :: B (S P0 Int) (S P0 Int) 16 | fib = (bfmap dynFib &&& (bfmap pred >>> (bfwd &&& bfmap pred))) >>> 17 | bbeval 0 >>> bright fibFail >>> bmerge 18 | where fibFail = bfmap $ const (-999999) 19 | 20 | dynFib :: Int -> B (S P0 Int :&: S P0 Int) (S P0 Int) 21 | dynFib n = if (n < 2) then bfst >>> bconst n 22 | else (fib *** fib) >>> bzipWith (+) 23 | 24 | fibPrint :: B (S P0 Int) S1 25 | fibPrint = (bfwd &&& fib) >>> bzipWith showFib >>> bprint >>> btrivial 26 | 27 | showFib :: Int -> Int -> String 28 | showFib n fibn = "Fib(" ++ show n ++ ") = " ++ show fibn 29 | 30 | -- rotate numbers from 0..9 repeatedly, at 1 Hz 31 | rotateI :: (Partition p) => B (S p ()) (S p Int) 32 | rotateI = bclockOfFreq 1 >>> bfmap tkI 33 | where tkI = fromInteger . (`div` nInnerPeriod) . (`mod` nOuterPeriod) . tmNanos 34 | nOuterPeriod = 10000000000 -- 10 seconds 35 | nInnerPeriod = 1000000000 -- 1 second 36 | 37 | rotateFib :: B (S P0 ()) S1 38 | rotateFib = rotateI >>> fibPrint 39 | 40 | main :: IO () 41 | main = do 42 | putStrLn "Hit Ctrl+C to exit" 43 | runSireaApp $ bconst 11 >>> fibPrint 44 | 45 | -------------------------------------------------------------------------------- /tst/Hello.hs: -------------------------------------------------------------------------------- 1 | -- some tests for behaviors. 2 | module Main 3 | ( main 4 | ) where 5 | 6 | import Sirea.Prelude 7 | 8 | bHelloWorld = bconst "Hello, World!" >>> bprint 9 | 10 | main :: IO () 11 | main = 12 | print "before hw app (ctrl+c to halt)" >> 13 | runSireaApp bHelloWorld >> 14 | print "after hw app" 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /tst/RotDyn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | -- | Test of long-life for dynamics, via three rotations: 4 | -- rotate 5 dynamic behaviors 5 | -- rotate 6 inputs on left 6 | -- rotate 7 inputs on right 7 | -- for a total 210 combinations based on clock. 8 | module Main 9 | ( main 10 | ) where 11 | 12 | import Sirea.Prelude 13 | import Sirea.Clock 14 | import Sirea.Time 15 | 16 | rotate567 :: (Partition p) => B (S p ()) (S p Int :&: S p Int :&: S p Int) 17 | rotate567 = bclockOfFreq 3 >>> bfmap tmNanos >>> bfmap (`div` 333333333) >>> 18 | (bfmap (`mod` 5) &&& bfmap (`mod` 6) &&& bfmap (`mod` 7)) >>> 19 | (bfmap fromInteger *** bfmap fromInteger *** bfmap fromInteger) 20 | 21 | add, sub, mul, pow, ssq :: B (S p Int :&: S p Int) (S p Int) 22 | add = bzipWith (+) 23 | sub = bzipWith (-) 24 | pow = bzipWith (^) 25 | mul = bzipWith (*) 26 | ssq = bzipWith (\ b c -> (b*b) + (c*c)) 27 | 28 | nToF :: Int -> B (S p Int :&: S p Int) (S p Int) 29 | nToF 0 = add 30 | nToF 1 = sub 31 | nToF 2 = pow 32 | nToF 3 = mul 33 | nToF 4 = ssq 34 | nToF _ = error "illegal behavior" 35 | 36 | nToFEval :: B (S p Int :&: S p Int :&: S p Int) (S p Int) 37 | nToFEval = bfirst (bfmap nToF) >>> bbeval 0 >>> bright (bconst 999) >>> bmerge 38 | 39 | zipAll :: B (S p a :&: S p b :&: S p c) (S p (a,(b,c))) 40 | zipAll = bsecond bzip >>> bzip 41 | 42 | main :: IO () 43 | main = runSireaApp $ 44 | rotate567 >>> 45 | (zipAll &&& nToFEval) >>> 46 | bzip >>> 47 | bprint 48 | 49 | -------------------------------------------------------------------------------- /tst/TimeStamp.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Sirea.Prelude 5 | 6 | main = runSireaApp $ record |*| report 7 | 8 | record = btickOfFreq 3 >>> bsplitOn even >>> bleft (bconst () >>> btimeStamp "r") 9 | report = btimeStampMon "r" >>> bprint 10 | 11 | 12 | -------------------------------------------------------------------------------- /tst/TimeTrigger.hs: -------------------------------------------------------------------------------- 1 | -- clock (on console, for now) 2 | -- todo: add a UI clock. 3 | module Main 4 | ( main 5 | ) where 6 | 7 | import Sirea.Prelude 8 | import Sirea.Clock 9 | import Sirea.Time 10 | import Sirea.TimeTrigger 11 | import Control.Exception (assert) 12 | 13 | -- a better way to show the clock... 14 | timeString :: T -> String 15 | timeString t = 16 | let nDay = tmNanos t in 17 | let sDay = nDay `div` 1000000000 in 18 | let (mDay,s) = sDay `divMod` 60 in 19 | let (hDay,m) = mDay `divMod` 60 in 20 | s2 hDay ++ ":" ++ s2 m ++ ":" ++ s2 s 21 | where s2 x = assert ((x >= 0) && (x < 100)) $ 22 | if x < 10 23 | then "0" ++ show x 24 | else show x 25 | 26 | ttshow (t,b) = timeString t ++ " -> " ++ show b 27 | bttshow = bprintWith ttshow 28 | 29 | bTT :: DT -> B (S P0 ()) (S P0 ()) 30 | bTT dt = bvoid $ bclockSeconds >>> bfmap (`addTime` dt) >>> (bfwd &&& btimeTrigger) >>> bzip >>> bttshow 31 | 32 | bTT0 = bTT 0 33 | bTT1 = bTT 1 34 | bTT2 = bTT 0.5 35 | 36 | 37 | main :: IO () 38 | main = 39 | print "before clock app" >> 40 | runSireaApp bTT2 >> 41 | print "after clock app" 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /tst/TstCross.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, NoMonomorphismRestriction #-} 2 | 3 | module Main where 4 | 5 | import Data.Function (fix) 6 | import Data.Typeable 7 | import Sirea.Prelude 8 | 9 | data X deriving Typeable 10 | data Y deriving Typeable 11 | data Z deriving Typeable 12 | type P1 = Pt X 13 | type P2 = Pt Y 14 | type P3 = Pt Z 15 | 16 | tst = ini >>> xyz >>> bvoid r0 >>> yzxy >>> r0 where 17 | ini = bconst "" >>> touchP0 18 | xyz = x >>> y >>> z 19 | yzxy = y >>> z >>> x >>> y 20 | x = cross >>> touchP1 21 | y = cross >>> touchP2 22 | z = cross >>> touchP3 23 | r0 = cross >>> touchP0 >>> bprint 24 | 25 | --cross :: (Partition p, Partition p') => B (S p String) (S p' String) 26 | cross = bfmap (++ "->") >>> bcross 27 | 28 | --touch :: (Typeable p) => B (S p String) (S p String) 29 | touch = fix $ \ b -> bfmap (++ (pdesc b)) 30 | 31 | --pdesc :: (Typeable p) => B (S p x) y -> String 32 | pdesc = show . typeOf . getP 33 | 34 | getP :: B (S p x) y -> p 35 | getP _ = undefined 36 | 37 | touchP0 :: B (S P0 String) (S P0 String) 38 | touchP0 = touch 39 | 40 | touchP1 :: B (S P1 String) (S P1 String) 41 | touchP1 = touch 42 | 43 | touchP2 :: B (S P2 String) (S P2 String) 44 | touchP2 = touch 45 | 46 | touchP3 :: B (S P3 String) (S P3 String) 47 | touchP3 = touch 48 | 49 | main = runSireaApp tst 50 | 51 | 52 | 53 | 54 | -------------------------------------------------------------------------------- /tst/TstDeMon.hs: -------------------------------------------------------------------------------- 1 | -- some tests for behaviors. 2 | {-# LANGUAGE TypeOperators #-} 3 | module Main 4 | ( main 5 | ) where 6 | 7 | import Sirea.Prelude 8 | import Sirea.UnsafeLink 9 | import Sirea.UnsafeIO 10 | import Sirea.Clock 11 | import Sirea.Time 12 | import Sirea.DemandMonitor 13 | import Control.Monad (unless) 14 | import qualified Data.Set as S 15 | import Debug.Trace 16 | 17 | -- assertions 18 | assertb :: (Show a) => String -> (a -> Bool) -> B (S P0 a) (S P0 a) 19 | assertb tstName test = bvoid $ bfmap (\a -> (test a,show a)) >>> unsafeOnUpdateB mkAssert 20 | where mkAssert _ = return doAssert 21 | doAssert t (b,a) = 22 | if b then putStrLn ("PASS: " ++ tstName ++ " @ " ++ show t ++ " (" ++ a ++ ")") 23 | else putStrLn ("FAIL: " ++ tstName ++ " @ " ++ show t ++ " (" ++ a ++ ")") 24 | 25 | tstInactive = snd amon >>> assertb "tstInactive" (== False) 26 | where amon = activityMonitor "tstInactive" 27 | tstActive1 = fst amon >>> snd amon >>> assertb "tstActive1" (== True) 28 | where amon = activityMonitor "tstActive1" 29 | tstActive2 = (fst amon &&& snd amon) >>> bsnd >>> assertb "tstActive2" (== True) 30 | where amon = activityMonitor "tstActive2" 31 | tstInactive2 = snd dmon >>> assertb "tstInactive2" (S.null) 32 | where dmon = demandMonitor "tstInactive2" 33 | inject = bconst (0 :: Int) >>> fst dmon -- to infer type, not used 34 | 35 | tstNums = bvoid $ inject >>> monitor >>> assertb "tstNums" ((== [3,4,5,7]) . S.toAscList) 36 | where inject = input 7 |*| input 3 |*| input 5 |*| input 4 37 | input n = bconst (int n) >>> fst deMon 38 | monitor = snd deMon 39 | deMon = demandMonitor "tstNums" 40 | 41 | allTests = tstInactive |*| tstActive1 |*| tstActive2 |*| tstNums |*| tstInactive2 42 | 43 | main :: IO () 44 | main = runSireaApp $ allTests 45 | 46 | tstCycle :: B (S P0 ()) (S P0 ()) 47 | tstCycle = snd dm >>> bdelay 0.1 >>> bfmap addOne >>> bprint >>> fst dm 48 | where dm = demandMonitor "tstCycle" 49 | addOne = succ . S.findMax . S.insert (0 :: Int) 50 | 51 | -- 'int' is just a type annotation to help inference 52 | int :: Int -> Int 53 | int = id 54 | 55 | -------------------------------------------------------------------------------- /tst/TstPure.hs: -------------------------------------------------------------------------------- 1 | -- some tests for behaviors. 2 | {-# LANGUAGE TypeOperators #-} 3 | module Main 4 | ( main 5 | ) where 6 | 7 | import Sirea.Prelude 8 | import Sirea.UnsafeIO 9 | import Sirea.Clock 10 | import Sirea.Time 11 | import Control.Monad (unless) 12 | 13 | -- assertions 14 | assertb :: String -> (a -> Bool) -> B (S P0 a) (S P0 a) 15 | assertb tstName test = bvoid $ bfmap test >>> unsafeOnUpdateB mkAssert 16 | where mkAssert _ = return doAssert 17 | doAssert _ b = 18 | if b then putStrLn ("PASS: " ++ tstName) 19 | else ioError $ userError ("FAIL: " ++ tstName) 20 | 21 | -- test for dead code due to binl or binr - shouldn't even create bcx. 22 | assertDeadOnInput :: String -> B (S P0 x) (S P0 x) 23 | assertDeadOnInput msg = bvoid $ bconst () >>> unsafeOnUpdateB mkAssert 24 | where mkAssert _ = ioError (userError ("FAIL: " ++ msg)) >> undefined 25 | 26 | -- test for dead code on output. This requires a lazy assertion, otherwise 27 | -- the assertion itself would keep the behavior alive for output. 28 | assertDeadOnOutput :: String -> B (S P0 ()) (S P0 ()) 29 | assertDeadOnOutput msg = bconst () >>> unsafeOnUpdateBL mkAssert 30 | where mkAssert _ = ioError (userError ("FAIL: " ++ msg)) >> undefined 31 | 32 | 33 | tstConst = bvoid $ bconst 42 >>> assertb "tstConst" (== 42) 34 | tstFmap = bvoid $ bconst 7 >>> bfmap (* 6) >>> assertb "tstFmap" (== 42) 35 | tstZip = bvoid $ (bconst 7 &&& bconst 6) >>> bzipWith (*) >>> assertb "tstZip" (== 42) 36 | tstSwap = bvoid $ bdup >>> (bconst 7 *** bconst 6) >>> bswap >>> (assertb "tstSwap1" (== 6) *** assertb "tstSwap2" (== 7)) 37 | tstSplitL = bvoid $ bconst (Left 7) >>> bsplit >>> (assertb "tstSplitL" (== 7) +++ assertb "tstSplitL" (== 6)) 38 | tstSplitR = bvoid $ bconst (Right 6) >>> bsplit >>> (assertb "tstSplitR" (== 7) +++ assertb "tstSplitR" (== 6)) 39 | tstInL = bvoid $ binl >>> bright (assertDeadOnInput "tstInL lives in R") >>> bleft (assertb "tstInL" (== ())) 40 | tstInR = bvoid $ binr >>> bleft (assertDeadOnInput "tstInR lives in L") >>> bright (assertb "tstInR" (== ())) 41 | tstDeadOutput = bvoid (assertDeadOnOutput "tstDeadOutput lives") >>> assertb "tstDeadOutput" (== ()) 42 | 43 | tstDisjoinL = bvoid $ (bconst (Left 7) &&& bconst 6) 44 | >>> bfirst bsplit -- ((Int :|: Int) :&: Int) 45 | >>> bdisjoinrz 46 | >>> (bzipWith (*) +++ bzipWith (*)) 47 | >>> (assertb "tstDisjoinL" (== 42) +++ assertb "tstDisjoinL in R?" (const False)) 48 | 49 | tstDisjoinR = bvoid $ (bconst (Right 7) &&& bconst 6) 50 | >>> bfirst bsplit 51 | >>> bdisjoinrz 52 | >>> (bzipWith (*) +++ bzipWith (*)) 53 | >>> (assertb "tstDisjoinR in L?" (const False) +++ assertb "tstDisjoinR" (== 42)) 54 | 55 | --tstFail = bvoid $ assertb "tstFail" (const False) 56 | 57 | tstAssocp = bvoid $ bdup >>> bsecond bdup >>> (bconst 7 *** (bconst 2 *** bconst 3)) >>> 58 | bassoclp >>> bfirst (bzipWith (*)) >>> bzipWith (*) >>> assertb "tstAssocp" (== 42) 59 | 60 | 61 | allTests = tstConst >>> tstFmap >>> tstZip >>> tstSwap >>> tstAssocp 62 | >>> tstSplitL >>> tstSplitR >>> tstInL >>> tstInR 63 | >>> tstDisjoinL >>> tstDisjoinR 64 | >>> tstDeadOutput 65 | >>> bvoid (bconst "Hit Ctrl+C to End!" >>> bprint) 66 | 67 | 68 | --joinTests :: 69 | -- seems like should have a monoid, here. 70 | 71 | -- rotate from 0..99 then back again, quickly (every 1/10th second) 72 | -- this is intended to serve as a simple variable for tests. 73 | rotateI :: B (S P0 ()) (S P0 Int) 74 | rotateI = bclockOfFreq 10 >>> bfmap tkI 75 | where tkI = fromInteger . (`div` sTenth) . (`mod` sTen) . tmNanos 76 | sTen = 10000000000 -- 10 seconds 77 | sTenth = 100000000 -- 100 milliseconds 78 | 79 | cascade :: B (S P0 ()) (S P0 Int :|: S P0 Int) 80 | cascade = rotateI >>> bsplitOn (\ x -> (x `mod` 20 < 10)) >>> (bprintWith show +++ bprintWith (\x -> " " ++ show x)) 81 | 82 | 83 | 84 | -- tests to perform: 85 | -- delay and synch 86 | -- 87 | -- anticipation (bpeek) 88 | -- multi-threaded computation - cross, return 89 | -- dead-code elimination 90 | -- on target (bfst/bsnd) 91 | -- on source (binl/binr) 92 | -- split... just test twice with Left and Right? 93 | -- 94 | -- Might be nice to add a few utilities to sirea-core: 95 | -- logging to console, runtime assertions 96 | -- 97 | 98 | main :: IO () 99 | main = runSireaApp $ allTests 100 | 101 | 102 | -- HOW will I make it convenient to write tests 103 | -- for Sirea? Perhaps use some sort of `expect` 104 | -- model? use unsafeOnUpdateB to push updates 105 | -- to a channel for unit testing? 106 | 107 | 108 | -- TESTS TO WRITE: 109 | -- fmap 110 | -- bzip 111 | -- bsplit 112 | -- bsynch 113 | -- 114 | 115 | --------------------------------------------------------------------------------