そのノードが他のネストされたマシンになることができる状態マシンをエンコードする

Question

私は、そのノードがHaskellのコールスタックを持つ他のマシンになることができる状態マシンをモデル化しようとしています。

module Cont (Cont(..)) where 

data Cont where 
    -- continue in the same machine 
    Cont :: Show s => s -> Cont 

    -- fork a new machine 
    Start :: (Show s, Show s') => s -> s' -> Cont 

    -- final state 
    End :: Show s => s -> Cont 

我々はどちらか

• 同じマシンに続行することができます：たとえばBarについては

  は

  module Bar (BarState(..), run) where 
  import Cont 
  
  data BarState = BInit | BMid | BEnd deriving Show 
  
  run BInit = Cont BMid 
  run BMid = End BEnd 
  

  Contタイプは、状態遷移を説明することにより、符号化されている非常に単純なマシンですby Cont s

それだけで Contと Endを使用していますので
• コール新しいマシンStart s s'
• がEnd s

Barによって状態sでマシンを終了しますが、他のフローを呼び出すことはありませんが、Fooはへの呼び出しを行うマシンですBar：

module Foo (FooState(..), run) where 
import qualified Bar as Bar 
import Cont 

data FooState = FInit | FBar | FEnd deriving Show 

run FInit = Start FBar Bar.BInit 
run FBar = End FEnd 

マシンはある時点で1つの状態にあり、どのマシンでも別のマシンを呼び出すことができます（Start s s'）。私は状態のスタックと私の全体のユーザーの状態を説明します。

import qualified Bar as Bar 
import qualified Foo as Foo 
import Cont 

data Stack s = Empty | s ::: Stack s ; infixr 5 ::: 

data States = FooState Foo.FooState | BarState Bar.BarState 

run :: Stack States -> Stack States 
run Empty = error "Empty stack" 
run (s ::: rest) = proceed (run' s) rest 

run' :: States -> Cont 
run' (FooState s) = Foo.run s 
run' (BarState s) = Bar.run s 

proceed :: Cont -> Stack States -> Stack States 
proceed (Cont s) rest = undefined ::: rest 
proceed (Start s s') rest = undefined ::: undefined ::: rest 
proceed (End s) rest = rest 

問題は、私はsContでコンストラクタのパターンマッチではないということです。

私の最終目標は、任意の有効な状態からのフローを続けることを可能にする直列化可能スタックを持つことです。例：

run [FInit] -> [BInit, FInit] 
run [BInit, FInit] -> [BEnd, FInit] 
run [BMid, FInit] -> [BEnd, FInit] 
run [BEnd, FInit] -> [FEnd] 

この例のモジュールのソースコードはhereです。

このモデルをエンコードするには、より良い方法があるかもしれませんが、私は私のものに限定されません。

Answer 1

パターンマッチは必要ありません。私が理解したように、必要なのはステップを実行してシリアライズ/デシリアライズすることだけです。これは、正確なタイプを知らなくても実行できます。

{-# LANGUAGE UnicodeSyntax #-} 
{-# OPTIONS_GHC -fno-warn-tabs #-} 

module States (
    ) where 

import Prelude.Unicode 

import Control.Arrow 
import Text.Read (Read(readsPrec), readMaybe) 

-- | State is something, which have next action and string representation 
data State = State { 
    next ∷ Cont, 
    save ∷ String } 

instance Show State where 
    show = save 

-- | Stack is list of states 
type Stack = [State] 

-- | Action operates on 'State' 
data Cont = Cont State | Start State State | End State deriving (Show) 

-- | Converts actual data to 'State' 
cont ∷ IsState s ⇒ s → Cont 
cont = Cont ∘ state 

start ∷ (IsState s, IsState s') ⇒ s → s' → Cont 
start x x' = Start (state x) (state x') 

end ∷ IsState s ⇒ s → Cont 
end = End ∘ state 

run ∷ Stack → Stack 
run [] = error "empty stack" 
run (s : ss) = proceed (next s) ss 

proceed ∷ Cont → Stack → Stack 
proceed (Cont s) rest = s : rest 
proceed (Start s s') rest = s' : s : rest 
proceed (End s) rest = rest 

serialize ∷ Stack → [String] 
serialize = map save 

-- | Here we have to provide some type in order to know, which 
-- read functions to use 
deserialize ∷ IsState s ⇒ [String] → Maybe [s] 
deserialize = mapM readMaybe 

class (Read s, Show s) ⇒ IsState s where 
    step ∷ s → Cont 
    -- | No need of implementation, just to allow using when implementing step 
    state ∷ s → State 
    state x = State (step x) (show x) 

-- | Convert actual data to stack 
stack ∷ IsState s ⇒ [s] → Stack 
stack = map state 

-- | Union of states, to specify type of 'deserialize' 
data BiState l r = LState l | RState r 

instance (Read l, Read r) ⇒ Read (BiState l r) where 
    readsPrec p s = map (first LState) (readsPrec p s) ++ map (first RState) (readsPrec p s) 

instance (Show l, Show r) ⇒ Show (BiState l r) where 
    show (LState x) = show x 
    show (RState y) = show y 

instance (IsState l, IsState r) ⇒ IsState (BiState l r) where 
    step (LState x) = step x 
    step (RState y) = step y 

-- Test data 

data BarState = BInit | BMid | BEnd deriving (Read, Show) 
data FooState = FInit | FBar | FEnd deriving (Read, Show) 

instance IsState BarState where 
    step BInit = cont BMid 
    step BMid = end BEnd 

instance IsState FooState where 
    step FInit = start FBar BInit 
    step FBar = end FEnd 

-- Usage 

test' ∷ IO() 
test' = do 
    let 
     start' = [state FInit] 
     next' = run start' 
    print next' -- [BInit,FBar] 
    let 
     saved' = serialize next' 
     Just loaded' = deserialize saved' ∷ Maybe [BiState FooState BarState] 
     next'' = run next' 
    print next'' -- [BMid,FBar] 
    print $ run $ stack loaded' -- [BMid,FBar] too 
    let 
     go [] = putStrLn "done!" 
     go st = print st' >> go st' where 
      st' = run st 
    go next'' 

-- output: 
-- [BInit,FBar] 
-- [BMid,FBar] 
-- [BMid,FBar] 
-- [FBar] 
-- [] 
-- done!