haskell - 编码一个状态机，其节点可以是其他嵌套机器

Question

我正在尝试建模一个状态机，其节点可以是具有 Haskell 中的调用堆栈的其他机器。

例如 Bar 是一个相当简单的机器，由

编码

module Bar (BarState(..), run) where
import Cont

data BarState = BInit | BMid | BEnd deriving Show

run BInit = Cont BMid
run BMid = End BEnd

Cont 类型描述状态转换:

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

我们可以

• 通过继续在同一台机器上继续
• 调用新机器Start s s'
• 通过 End s 在状态 s 结束机器

Bar 不会调用任何其他流程，因此它只使用 Cont 和 End，但 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

一台机器有时可以处于一种状态，并且任何机器都可以调用另一台机器(通过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

问题是我无法在 Cont 构造函数中的 s 上进行模式匹配。

我的最终目标是拥有一个可序列化的堆栈，使我能够从任何有效状态继续流程。例如:

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!