initial commit

hyperthunk · hyperthunk · commit c149cf537db0 · 2017-03-15T21:12:29.000Z
diff --git a/LICENCE b/LICENCE
@@ -0,0 +1,30 @@
+Copyright Tim Watson, 2012-2013.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the author nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
@@ -1,2 +1,24 @@
-# distributed-process-fsm
-Cloud Haskell implementation of Erlang's gen_statem (ish)
+# distribributed-process-fsm
+[![Build Status](https://secure.travis-ci.org/haskell-distributed/distributed-process-fsm.png)](http://travis-ci.org/haskell-distributed/distributed-process-fsm)
+[![Code Coverage](https://coveralls.io/repos/github/haskell-distributed/distributed-process-fsm/badge.svg?branch=master)](https://coveralls.io/github/haskell-distributed/distributed-process-fsm?branch=master)
+[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)](https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29)
+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/haskell-distributed)
+
+### Releases, LTS
+Github: [![GitHub tag](https://img.shields.io/github/tag/haskell-distributed/distributed-process-fsm.svg)]() [![GitHub commits](https://img.shields.io/github/commits-since/haskell-distributed/distributed-process-fsm/release-0.0.1.svg)]()
+
+Hackage: [![Releases](https://img.shields.io/hackage/v/distributed-process-fsm.svg)](https://hackage.haskell.org/package/distributed-process-fsm) [![Dependencies](https://img.shields.io/hackage-deps/v/distributed-process-fsm.svg)](http://packdeps.haskellers.com/feed?needle=distributed-process-fsm)
+
+Stackage: [![LTS 6](https://www.stackage.org/package/distributed-process-fsm/badge/lts-6)](http://stackage.org/lts-6/package/distributed-process-fsm)
+[![NIGHTLY](https://www.stackage.org/package/distributed-process-fsm/badge/nightly)](http://stackage.org/nightly/package/distributed-process-fsm)
+
+### Getting Help / Raising Issues
+[![Slack Sign Up/In](https://rauchg-slackin-dxinpkuzrg.now.sh/badge.svg)](https://rauchg-slackin-dxinpkuzrg.now.sh/) [![Slack Sign Up/In](https://img.shields.io/badge/Freenode-%23haskell--distributed-ff69b4.svg)]()
+
+As well as our Slack channels (you'll need to sign up, but there is a form for doing so) and #haskell-distributed on freenode, you can contact the distributed-haskell@googlegroups.com mailing list for help and comments. Please also see http://haskell-distributed.github.com for documentation, user guides, tutorials and assistance.
+
+Visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-client-server/issues) to submit issues.
+
+### License
+
+This package is made available under a 3-clause BSD-style license.
diff --git a/Setup.lhs b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/distributed-process-fsm.cabal b/distributed-process-fsm.cabal
@@ -0,0 +1,47 @@
+name:           distributed-process-fsm
+version:        0.0.1
+cabal-version:  >=1.8
+build-type:     Simple
+license:        BSD3
+license-file:   LICENCE
+stability:      experimental
+Copyright:      Tim Watson 2017
+Author:         Tim Watson
+Maintainer:     Tim Watson <watson.timothy@gmail.com>
+Stability:      experimental
+Homepage:       http://github.com/haskell-distributed/distributed-process-fsm
+Bug-Reports:    http://github.com/haskell-distributed/distributed-process-fsm/issues
+synopsis:       The Cloud Haskell implementation of Erlang/OTP gen_statem
+description:    Modelled after Erlang OTP's gen_statem, this framework provides similar
+                facilities for Cloud Haskell.
+category:       Control
+Tested-With:    GHC==7.10.3 GHC==8.0.1 GHC==8.0.2
+data-dir:       ""
+
+source-repository head
+  type:      git
+  location:  https://github.com/haskell-distributed/distributed-process-fsm
+
+library
+  build-depends:
+                   base >= 4.8.2.0 && < 5,
+                   distributed-process >= 0.6.6 && < 0.7,
+                   distributed-process-extras >= 0.3.1 && < 0.4,
+                   distributed-process-async >= 0.2.4 && < 0.3,
+                   distributed-process-client-server >= 0.2.0 && < 0.3,
+                   binary >= 0.6.3.0 && < 0.9,
+                   deepseq >= 1.3.0.1 && < 1.6,
+                   mtl,
+                   containers >= 0.4 && < 0.6,
+                   unordered-containers >= 0.2.3.0 && < 0.3,
+                   stm >= 2.4 && < 2.5,
+                   time > 1.4 && < 1.8,
+                   transformers,
+                   exceptions >= 0.5
+  extensions:      CPP
+  hs-source-dirs:   src
+  ghc-options:      -Wall
+  exposed-modules:
+                   Control.Distributed.Process.FSM
+  other-modules:
+                   Control.Distributed.Process.FSM.Internal.Types
diff --git a/src/Control/Distributed/Process/FSM.hs b/src/Control/Distributed/Process/FSM.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE PatternGuards              #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE RankNTypes                 #-}
+
+module Control.Distributed.Process.FSM where
+
+import Control.Distributed.Process (Process)
+import Control.Distributed.Process.Extras
+ ( ExitReason(ExitShutdown)
+ )
+import Control.Distributed.Process.Extras.Time
+ ( TimeInterval
+ , seconds
+ )
+import Control.Distributed.Process.Serializable (Serializable)
+import Control.Monad (void)
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.IO.Class (MonadIO)
+import qualified Control.Monad.State.Strict as ST
+  ( MonadState
+  , StateT
+  , get
+  , lift
+  , runStateT
+  )
+import Data.Binary (Binary)
+import Data.Typeable (Typeable)
+import GHC.Generics
+
+data State s d m = State
+
+newtype FSM s d m o = FSM {
+   unFSM :: ST.StateT (State s d m) Process o
+ }
+ deriving ( Functor
+          , Monad
+          , ST.MonadState (State s d m)
+          , MonadIO
+          , MonadFix
+          , Typeable
+          , Applicative
+          )
+
+data Action = Consume | Produce | Skip
+data Transition s m = Remain | PutBack m | Change s
+data Event m = Event
+
+data Step s d where
+  Start     :: s -> d -> Step s d
+  Await     :: (Serializable m) => Event m -> Step s d -> Step s d
+  Always    :: FSM s d m (Transition s d) -> Step s d
+  Perhaps   :: (Eq s) => s -> FSM s d m (Transition s d) -> Step s d
+  Matching  :: (m -> Bool) -> FSM s d m (Transition s d) -> Step s d
+  Sequence  :: Step s d -> Step s d -> Step s d
+  Alternate :: Step s d -> Step s d -> Step s d
+  Reply     :: (Serializable r) => FSM s f m r -> Step s d
+
+type Pipeline = forall s d . Step s d
+
+initState :: forall s d . s -> d -> Step s d
+initState = Start
+
+-- endState :: Action -> State
+-- endState = undefined
+
+enter :: forall s d m . s -> FSM s d m (Transition s d)
+enter = undefined
+
+stopWith :: ExitReason -> Action
+stopWith = undefined
+
+event :: (Serializable m) => Event m
+event = Event
+
+currentState :: forall s d m . FSM s d m s
+currentState = undefined
+
+reply :: forall s d m r . (Serializable r) => FSM s d m r -> Step s d
+reply = Reply
+
+timeout :: Serializable a => TimeInterval -> a -> FSM s d m (Transition s d)
+timeout = undefined
+
+set :: forall s d m . (d -> d) -> FSM s d m ()
+set = undefined
+
+put :: forall s d m . d -> FSM s d m ()
+put = undefined
+
+(.|) :: Step s d -> Step s d -> Step s d
+(.|) = Alternate
+infixr 9 .|
+
+(|>) :: Step s d -> Step s d -> Step s d
+(|>) = Sequence
+infixr 9 |>
+
+(<|) :: Step s d -> Step s d -> Step s d
+(<|) = undefined
+infixr 9 <|
+
+(~>) :: forall s d m . (Serializable m) => Event m -> Step s d -> Step s d
+(~>) = Await
+infixr 9 ~>
+
+(~@) :: forall s d m . (Eq s) => s -> FSM s d m (Transition s d) -> Step s d
+(~@) = Perhaps
+infixr 9 ~@
+
+allState :: forall s d m . FSM s d m (Transition s d) -> Step s d
+allState = Always
+
+(~?) :: forall s d m . (m -> Bool) -> FSM s d m (Transition s d) -> Step s d
+(~?) = Matching
+
+start :: Pipeline -> Process ()
+start = const $ return ()
+
+data StateName = On | Off deriving (Eq, Show, Typeable, Generic)
+instance Binary StateName where
+
+data Reset = Reset deriving (Eq, Show, Typeable, Generic)
+instance Binary Reset where
+
+type StateData = Integer
+type ButtonPush = ()
+type Stop = ExitReason
+
+initCount :: StateData
+initCount = 0
+
+startState :: Step StateName Integer
+startState = initState Off initCount
+
+demo :: Step StateName StateData
+demo = startState
+         |> (event :: Event ButtonPush)
+              ~> (  (On  ~@ (set (+1) >> enter Off))
+                 .| (Off ~@ (set (+1) >> enter On))
+                 ) <| (reply currentState)
+         .| (event :: Event Stop)
+              ~> ((== ExitShutdown) ~? (timeout (seconds 3) Reset))
+         .| (event :: Event Reset) ~> (allState $ put initCount >> enter Off)
+--        .| endState $ stopWith ExitNormal
diff --git a/src/Control/Distributed/Process/FSM/Internal/Types.hs b/src/Control/Distributed/Process/FSM/Internal/Types.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE PatternGuards              #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE Rank2Types                 #-}
+
+module Control.Distributed.Process.FSM.Internal.Types
+where
+
+data Foo = Foo
diff --git a/stack.yaml b/stack.yaml
@@ -0,0 +1,15 @@
+resolver: nightly-2017-02-03
+
+packages:
+- '.'
+- location:
+    git: https://github.com/haskell-distributed/distributed-process-client-server.git
+    commit: 8ad94262693eb66a158dbcd3b3908a2fc0888968
+  extra-dep: true
+
+extra-deps:
+- distributed-process-0.6.6         # missing snapshot
+- distributed-process-extras-0.3.1  # missing snapshot
+- distributed-process-async-0.2.4   # missing snapshot
+- distributed-process-systest-0.1.1 # missing prior to Jan-2017
+- rematch-0.2.0.0

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+#!/usr/bin/env runhaskell`
	`2`	`+> import Distribution.Simple`
	`3`	`+> main = defaultMain`