wizard.md

Wizard

Somebody on reddit asked for a nice way of doing wizards functionally.

At least theoretically you can combine free applicatives with free monads to get a branching wizard.

Let's see how.

Let's start with how to define a form element.

1. Reading an element can fail
2. Element has a name
3. Element has a help text

type FieldReader a = String -> Either String a

data Field a
  = Field { name     :: Name
          , validate :: FieldReader a
          , help     :: Help }

With this we need to make it into a free applicative. This is easy, and note that it should only care about the Field primitive.

type Form = Ap Field

field :: Name -> FieldReader a -> Help -> Form a
field n fr h = liftAp $ Field n fr h

Given this, we can start writing our interpreters since they only need to care about the primitives.

There's a few interesting functions in http://hackage.haskell.org/package/free-5.1.2/docs/Control-Applicative-Free.html such as

• runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a
• runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f a -> m

With this we can write the interpreters.

-- | Create a unique identifier
mkIdentifier :: MonadState Int m => m Text
mkIdentifier = modify succ >> gets (mappend "input_" . tshow)

-- | Render a form field into a html input element
--
-- Generates unique names for the elements
renderField :: MonadState Int m => Field a -> HtmlT m ()
renderField Field{..} = do
  identifier <- mkIdentifier
  label_ (toHtml name) <> input_ [type_ "text", id_ identifier]

-- | Evaluate a form input as a form element
--
-- This approximates taking a request body and fetching values from it
-- This function might fail if either the element isn't found or it fails the validation step
evalField :: MonadState Int m => Map Text String -> Field a -> ExceptT String m a
evalField env Field{..} = do
  identifier <- mkIdentifier
  maybe (notFound identifier) (liftEither . validate) $ M.lookup identifier env
  where
    notFound identifier = throwError $ "No value for " <> T.unpack identifier <> " found"

Given these functions are difficult to test unless I setup an actual server, I generated some helpers for dealing with CLI.

-- | Render a simple help string for a form element
renderHelp :: Field a -> Text
renderHelp Field{..} = name <> "\n\n" <> help <> "\n"

-- | Ask the user for a value for a form element and validate it
--
-- This function might fail if the input fails the validation step
queryField :: Field a -> ExceptT String IO a
queryField Field{..} = do
  liftIO $ T.putStrLn name
  ExceptT $ validate <$> liftIO getLine

With these primitives, we're ready to build a branching wizard. I'll create three forms, with the purpose that the forms given depend on the input on the previous forms. Note how each variant in the free monad takes the form as an element and returns the value of the form as an output.

data Person
  = Person { personName :: Text
           , personAge  :: Int }
  deriving Show

data Occupation
  = Occupation { occupationName :: Text
               , occupationTitle :: Text }
  deriving Show

data Schooling
  = Schooling { schoolingName :: Text
              , schoolingAverage :: Double }
  deriving (Show)

data Wizard f
  = PersonForm (Form Person) (Person -> f)
  | OccupationForm (Form Occupation) (Occupation -> f)
  | SchoolingForm (Form Schooling) (Schooling -> f)
  deriving Functor

wizard :: Free Wizard (Either (Person, Occupation) (Person, Schooling))
wizard = do
  person <- personForm
  case person of
       Person{personAge} | personAge > 18 -> Left . (person,) <$> occupationForm
                         | otherwise -> Right . (person,) <$> schoolingForm

We still need to generate the form steps. I'm just lifting the Wizard constructors in the free monad. The forms themselves are just applicatives done with the field primitive created above.

personForm :: Free Wizard Person
personForm = liftF (PersonForm form id)
  where
    form = Person <$> field "Name" strField "Your name" <*> field "Age" ageField "Your age"
    ageField x = intField x >>= \age -> if age > 0 then Right age else Left "Age should be positive"

occupationForm :: Free Wizard Occupation
occupationForm = liftF (OccupationForm form id)
  where
    form = Occupation <$> field "Name" strField "Your occupation" <*> field "Title" strField "Your title"

schoolingForm :: Free Wizard Schooling
schoolingForm = liftF (SchoolingForm form id)
  where
    form = Schooling <$> field "Name" strField "Your topmost school" <*> field "Average" readField "Your class average"

So now we have

• The free applicative representing a form
• Evaluators for the forms implemented through the form element
• The free monad for the wizard
• The branching wizard

Given this, we're still missing the free monad evaluator. In the CLI example, it should just ask the user for the input, if input fails, complain and retry. Given this, I can write

-- | Evaluate the wizard
--
-- It unpack each constructor, takes the form out of them, evaluates the form, retrying indefinitely until success
evalWizard :: Wizard a -> IO a
evalWizard = \case
  PersonForm pf f -> queryForm pf f
  OccupationForm pf f -> queryForm pf f
  SchoolingForm pf f -> queryForm pf f
  where
    queryForm form continue = fix $ \retry ->
      runExceptT (runAp queryField form) >>= either (\e -> onFail form e >> retry) (pure . continue)
    onFail form e = T.putStrLn (T.pack e) >> T.putStrLn (runAp_ renderHelp form)