title: Type-safe Flow (State Machine)
body: <p>I am trying to create a type-safe Question-Answer flow in Haskell. I am modeling QnA as a directed graph, similar to a FSM.</p>
  
  <p>Each node in the graph represent a question:</p>
  
  <pre><code>data Node s a s' = Node {
    question :: Question a,
    process :: s -&gt; a -&gt; s'
  }
  </code></pre>
  
  <p><code>s</code> is the input state, <code>a</code> is the answer to the question and <code>s'</code> is the output state. Nodes depend on the input state <code>s</code>, meaning that for processing the answer we have to be a in a particular state before. </p>
  
  <p><code>Question a</code> represent a simple question / answer producing an answer of type <code>a</code>.</p>
  
  <p>By type-safe I mean, for example given a node <code>Node2 :: si -&gt; a -&gt; s2</code>, if <code>si</code> depends on <code>s1</code> then all the paths ending with <code>Node2</code> must be passing through a node that produces <code>s1</code> first. (If <code>s1 == si</code> then all predecessors of <code>Node2</code>  must be producing <code>s1</code>).</p>
  
  <p><strong>An Example</strong></p>
  
  <p>QnA: In an online shopping website, we need to ask user's body size and favorite color.</p>
  
  <ol>
  <li><code>e1</code>: ask user if they know their size. If yes then go to <code>e2</code> otherwise go to <code>e3</code></li>
  <li><code>e2</code>: ask user's size and go to <code>ef</code> to ask the color.</li>
  <li><code>e3</code>: (user doesn't know their size), ask user's weight and go to <code>e4</code>.</li>
  <li><code>e4</code>: (after <code>e3</code>) ask user's height and calculate their size and go to <code>ef.</code></li>
  <li><code>ef</code>: ask user's favorite color and finish the flow with the <code>Final</code> result.</li>
  </ol>
  
  <p>In my model, <code>Edge</code>s connect <code>Node</code>s to each other:</p>
  
  <pre><code>data Edge s sf where
    Edge  :: EdgeId -&gt; Node s a s' -&gt; (s' -&gt; a -&gt; Edge s' sf) -&gt; Edge s sf
    Final :: EdgeId -&gt; Node s a s' -&gt; (s' -&gt; a -&gt; sf) -&gt; Edge s sf
  </code></pre>
  
  <p><code>sf</code> is the final result of the QnA, that here is: <code>(Bool, Size, Color)</code>.</p>
  
  <p>The QnA state at each moment can be represented by a tuple: <code>(s, EdgeId)</code>. This state is serializable and we should be able to continue a QnA by just knowing this state.</p>
  
  <pre><code>saveState :: (Show s) =&gt; (s, Edge s sf) -&gt; String
  saveState (s, Edge eid n _) = show (s, eid)
  
  getEdge :: EdgeId -&gt; Edge s sf
  getEdge = undefined --TODO
  
  respond :: s -&gt; Edge s sf -&gt; Input -&gt; Either sf (s', Edge s' sf)
  respond s (Edge ...) input = Right (s', Edge ...)
  respond s (Final ...) input = Left s' -- Final state
  
  -- state = serialized (s, EdgeId)
  -- input = user's answer to the current question
  main' :: String -&gt; Input -&gt; Either sf (s', Edge s' sf)
  main' state input =
    let (s, eid) = read state :: ((), EdgeId) --TODO
        edge = getEdge eid
    in respond s input edge
  </code></pre>
  
  <p><a href="https://i.stack.imgur.com/9bSVu.png" rel="noreferrer"><img src="https://i.stack.imgur.com/9bSVu.png" alt="Flow for determining user&#39;s dress size"></a></p>
  
  <p>Full code:</p>
  
  <pre class="lang-hs prettyprint-override"><code>{-# LANGUAGE GADTs, RankNTypes, TupleSections #-}
  
  type Input = String
  type Prompt = String
  type Color = String
  type Size = Int
  type Weight = Int
  type Height = Int
  
  data Question a = Question {
    prompt :: Prompt,
    answer :: Input -&gt; a
  }
  
  -- some questions 
  doYouKnowYourSizeQ :: Question Bool
  doYouKnowYourSizeQ = Question "Do you know your size?" read
  
  whatIsYourSizeQ :: Question Size
  whatIsYourSizeQ = Question "What is your size?" read
  
  whatIsYourWeightQ :: Question Weight
  whatIsYourWeightQ = Question "What is your weight?" read
  
  whatIsYourHeightQ :: Question Height
  whatIsYourHeightQ = Question "What is your height?" read
  
  whatIsYourFavColorQ :: Question Color
  whatIsYourFavColorQ = Question "What is your fav color?" id
  
  -- Node and Edge
  
  data Node s a s' = Node {
    question :: Question a,
    process :: s -&gt; a -&gt; s'
  }
  
  data Edge s sf where
    Edge  :: EdgeId -&gt; Node s a s' -&gt; (s' -&gt; a -&gt; Edge s' sf) -&gt; Edge s sf
    Final :: EdgeId -&gt; Node s a s' -&gt; (s' -&gt; a -&gt; sf) -&gt; Edge s sf
  
  data EdgeId = E1 | E2 | E3 | E4 | Ef deriving (Read, Show)
  
  -- nodes
  
  n1 :: Node () Bool Bool
  n1 = Node doYouKnowYourSizeQ (const id)
  
  n2 :: Node Bool Size (Bool, Size)
  n2 = Node whatIsYourSizeQ (,)
  
  n3 :: Node Bool Weight (Bool, Weight)
  n3 = Node whatIsYourWeightQ (,)
  
  n4 :: Node (Bool, Weight) Height (Bool, Size)
  n4 = Node whatIsYourHeightQ (\ (b, w) h -&gt; (b, w * h))
  
  n5 :: Node (Bool, Size) Color (Bool, Size, Color)
  n5 = Node whatIsYourFavColorQ (\ (b, i) c -&gt; (b, i, c))
  
  
  -- type-safe edges
  
  e1 = Edge E1 n1 (const $ \ b -&gt; if b then e2 else e3)
  e2 = Edge E2 n2 (const $ const ef)
  e3 = Edge E3 n3 (const $ const e4)
  e4 = Edge E4 n4 (const $ const ef)
  ef = Final Ef n5 const
  
  
  ask :: Edge s sf -&gt; Prompt
  ask (Edge _ n _) = prompt $ question n
  ask (Final _ n _) = prompt $ question n
  
  respond :: s -&gt; Edge s sf -&gt; Input -&gt; Either sf (s', Edge s' sf)
  respond s (Edge _ n f) i =
    let a  = (answer $ question n) i
        s' = process n s a
        n' = f s' a
    in Right undefined --TODO n'
  
  respond s (Final _ n f) i =
    let a  = (answer $ question n) i
        s' = process n s a
    in Left undefined --TODO s'
  
  
  -- User Interaction:
  
  saveState :: (Show s) =&gt; (s, Edge s sf) -&gt; String
  saveState (s, Edge eid n _) = show (s, eid)
  
  getEdge :: EdgeId -&gt; Edge s sf
  getEdge = undefined --TODO
  
  -- state = serialized (s, EdgeId) (where getEdge :: EdgeId -&gt; Edge s sf)
  -- input = user's answer to the current question
  main' :: String -&gt; Input -&gt; Either sf (s', Edge s' sf)
  main' state input =
    let (s, eid) = undefined -- read state --TODO
        edge = getEdge eid
    in respond s edge input
  </code></pre>
  
  <p>It's important for me to keep the edges type-safe. Meaning for instance incorrectly linking <code>e2</code> to <code>e3</code> must be a type error: <code>e2 = Edge E2 n2 (const $ const ef)</code> is fine by <code>e2 = Edge E2 n2 (const $ const e3)</code> must be an error.</p>
  
  <p>I have indicated my questions with <code>--TOOD</code>:</p>
  
  <ul>
  <li><p>Given my criteria for keeping edges type-safe, <code>Edge s sf</code> must have an input type variable (<code>s</code>) then how can I create <code>getEdge :: EdgeId -&gt; Edge s sf</code> function?</p></li>
  <li><p>How can I create the <code>respond</code> function that given the current state <code>s</code> and current edge <code>Edge s sf</code>, will return either the final state (if current edge is <code>Final</code>) or the next state and the next edge <code>(s', Edge s' sf)</code>?</p></li>
  </ul>
  
  <p>My design of <code>Node s a s'</code> and <code>Edge s sf</code> might be simply wrong. I don't have to stick with it.</p>