devforms-0.3.0.0: src/DevForms.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : DevForms
Description : A builder DSL for creating HTML survey forms

DevForms lets you define multi-page survey forms using a concise monadic
builder DSL. Forms are served via a built-in web server (Scotty), and
submissions are stored as JSONL files.

Each question type comes in two variants:

* A plain version (e.g. 'questionLikert') that uses default options.
* A @With@ version (e.g. 'questionLikertWith') that accepts a builder block
  for configuring options like 'setOptional' or bounds.

=== Example

@
main :: IO ()
main = devFormServer 9000 $ do
    form "Animal Survey" "animals" $ do
        questionLikert "I enjoy seeing animals"
        questionChoice "Favourite animal"
            ["Alpaca", "Bumblebee", "Camel", "Duck"]
        questionMultiChoiceWith "Which animals have you seen?" ["Alpaca", "Bumblebee", "Camel", "Duck"] $ do
            setMinSelections 1
            setMaxSelections 3
        questionDateWith "When would you like to visit the zoo?" $ setOptional
        questionIntegerWith "How many tickets?" $ do
            setLowerBoundInclusive 1
            setUpperBoundInclusive 10
@
-}
module DevForms (
    ServerBuilder,
    FormBuilder,
    QuestionBuilder,
    NumberQuestionBuilder,
    MultiChoiceQuestionBuilder,
    HasOptional (..),
    HasBounds (..),
    HasSelectionBounds (..),
    devFormServer,
    form,
    questionCheckbox,
    questionCheckboxWith,
    questionLikert,
    questionLikertWith,
    questionChoice,
    questionChoiceWith,
    questionMultiChoice,
    questionMultiChoiceWith,
    questionDate,
    questionDateWith,
    questionTime,
    questionTimeWith,
    questionInteger,
    questionIntegerWith,
    questionFloat,
    questionFloatWith,
    questionFreeText,
    questionFreeTextWith,
    questionRegexText,
    questionRegexTextWith,
) where

import Control.Monad.Writer
import Form (Form (..), FormBuilder)
import Question (
    HasBounds (..),
    HasOptional (..),
    HasSelectionBounds (..),
    MultiChoiceQuestionBuilder,
    NumberQuestionBuilder,
    NumberType (..),
    Question (..),
    QuestionBuilder,
    QuestionType (..),
    runIntegerQuestionBuilder,
    runMultiChoiceQuestionBuilder,
    runQuestionBuilder,
 )
import Server (Server (..), ServerBuilder, runServer)

{- | Start the devforms web server on the given port.

This is the top-level entry point for a devforms application. The second
argument is a 'ServerBuilder' block in which you define one or more forms
using 'form'. The server provides:

* Individual form pages with client-side validation
* A submission endpoint that stores answers in @answers-\<formId\>.jsonl@
-}
devFormServer :: Int -> ServerBuilder () -> IO ()
devFormServer = runServer

{- | Define a survey form.

The first argument is the human-readable title displayed at the top of the
form page. The second argument is a form identifier used for:

* URL routing — the form is served at @/form/\<formId\>@
* Persistent storage — submissions are appended to @answers-\<formId\>.jsonl@

The third argument is a 'FormBuilder' block where you add questions using
the @question*@ functions.
-}
form :: Text -> Text -> FormBuilder () -> ServerBuilder ()
form title formId formBuilder = do
    let f = appEndo (execWriter formBuilder) $ Form{title = title, formId = formId, questions = []}
    tell $ Endo $ \server@Server{forms} -> server{forms = forms <> [f]}

addQuestion :: (MonadWriter (Endo Form) m) => Question -> m ()
addQuestion question =
    tell $ Endo $ \f@Form{questions} -> f{questions = questions <> [question]}

{- | Add a yes\/no checkbox question with default options. Renders as a single
checkbox that the respondent can tick or leave unticked.
-}
questionCheckbox :: Text -> FormBuilder ()
questionCheckbox label = questionCheckboxWith label (pure ())

{- | Add a yes\/no checkbox question with custom options. Renders as a single
checkbox that the respondent can tick or leave unticked.

The second argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.
-}
questionCheckboxWith :: Text -> QuestionBuilder () -> FormBuilder ()
questionCheckboxWith questionText builder =
    addQuestion $ Question questionText QuestionCheckbox (runQuestionBuilder builder)

{- | Add a Likert-scale question with default options. Renders as a 5-point
agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\"
option.
-}
questionLikert :: Text -> FormBuilder ()
questionLikert label = questionLikertWith label (pure ())

{- | Add a Likert-scale question with custom options. Renders as a 5-point
agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\"
option.

The second argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.
-}
questionLikertWith :: Text -> QuestionBuilder () -> FormBuilder ()
questionLikertWith questionText builder =
    addQuestion $ Question questionText QuestionLikert (runQuestionBuilder builder)

{- | Add a multiple-choice question with default options. Renders as a group of
radio buttons — the respondent must select exactly one of the provided
options.

The first argument is the question label; the second is the list of choices.
-}
questionChoice :: Text -> [Text] -> FormBuilder ()
questionChoice label options = questionChoiceWith label options (pure ())

{- | Add a multiple-choice question with custom options. Renders as a group of
radio buttons — the respondent must select exactly one of the provided
options.

The first argument is the question label; the second is the list of choices.
The third argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.
-}
questionChoiceWith :: Text -> [Text] -> QuestionBuilder () -> FormBuilder ()
questionChoiceWith title qOptions builder =
    addQuestion $ Question title (QuestionChoice qOptions) (runQuestionBuilder builder)

{- | Add a multiple-choice question with default options. Renders as a group of
checkboxes — the respondent can select one or more of the provided options.

The first argument is the question label; the second is the list of choices.
By default, at least one selection is required. Use 'questionMultiChoiceWith'
to configure selection bounds or mark as optional.
-}
questionMultiChoice :: Text -> [Text] -> FormBuilder ()
questionMultiChoice label options = questionMultiChoiceWith label options (pure ())

{- | Add a multiple-choice question with custom options. Renders as a group of
checkboxes — the respondent can select one or more of the provided options.

The first argument is the question label; the second is the list of choices.
The third argument is a 'MultiChoiceQuestionBuilder' block where you can
configure selection bounds using 'setMinSelections' and 'setMaxSelections',
as well as shared options like 'setOptional'.

Selection bounds are enforced both client-side (via _hyperscript) and
server-side on submission. If the question is optional, the respondent may
skip it entirely (zero selections), but if they select any options, the
min\/max constraints must be satisfied.

=== Example

@
questionMultiChoiceWith "Pick your toppings" ["Cheese", "Mushrooms", "Peppers", "Olives"] $ do
    setMinSelections 1
    setMaxSelections 3
@
-}
questionMultiChoiceWith :: Text -> [Text] -> MultiChoiceQuestionBuilder () -> FormBuilder ()
questionMultiChoiceWith title qOptions builder =
    addQuestion $ Question title (QuestionMultiChoice qOptions) (runMultiChoiceQuestionBuilder builder)

{- | Add a date-picker question with default options. Renders as an HTML date
input and stores the answer in @YYYY-MM-DD@ format.
-}
questionDate :: Text -> FormBuilder ()
questionDate label = questionDateWith label (pure ())

{- | Add a date-picker question with custom options. Renders as an HTML date
input and stores the answer in @YYYY-MM-DD@ format.

The second argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.
-}
questionDateWith :: Text -> QuestionBuilder () -> FormBuilder ()
questionDateWith questionText builder =
    addQuestion $ Question questionText QuestionDate (runQuestionBuilder builder)

{- | Add a time-picker question with default options. Renders as an HTML time
input and stores the answer in @HH:MM@ format.
-}
questionTime :: Text -> FormBuilder ()
questionTime label = questionTimeWith label (pure ())

{- | Add a time-picker question with custom options. Renders as an HTML time
input and stores the answer in @HH:MM@ format.

The second argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.
-}
questionTimeWith :: Text -> QuestionBuilder () -> FormBuilder ()
questionTimeWith questionText builder =
    addQuestion $ Question questionText QuestionTime (runQuestionBuilder builder)

-- | Add an integer input question with default options (no bounds).
questionInteger :: Text -> FormBuilder ()
questionInteger label = questionIntegerWith label (pure ())

{- | Add an integer input question with custom options. The second argument is
a 'NumberQuestionBuilder' block where you can configure bounds using
'setLowerBoundInclusive' and 'setUpperBoundInclusive', as well as shared
options like 'setOptional'. Bounds are enforced both client-side (via HTML
attributes) and server-side on submission.

=== Example

@
questionIntegerWith "How many pets do you have?" $ do
    setLowerBoundInclusive 0
    setUpperBoundInclusive 50
    setOptional
@
-}
questionIntegerWith :: Text -> NumberQuestionBuilder () -> FormBuilder ()
questionIntegerWith = questionNumberWith NumberInteger

-- | Add a float input question with default options (no bounds).
questionFloat :: Text -> FormBuilder ()
questionFloat label = questionFloatWith label (pure ())

{- | Add a float input question with custom options. The second argument is
a 'NumberQuestionBuilder' block where you can configure bounds using
'setLowerBoundInclusive' and 'setUpperBoundInclusive', as well as shared
options like 'setOptional'. Bounds are enforced both client-side (via HTML
attributes) and server-side on submission.

=== Example

@
questionFloatWith "How many pets do you have?" $ do
    setLowerBoundInclusive 0
    setUpperBoundInclusive 50
    setOptional
@
-}
questionFloatWith :: Text -> NumberQuestionBuilder () -> FormBuilder ()
questionFloatWith = questionNumberWith NumberFloat

questionNumberWith :: NumberType -> Text -> NumberQuestionBuilder () -> FormBuilder ()
questionNumberWith numberType title builder =
    addQuestion $ Question title (QuestionNumber numberType) (runIntegerQuestionBuilder builder)

{- | Add a free-text textarea question with default options. The respondent can
enter arbitrary text.
-}
questionFreeText :: Text -> FormBuilder ()
questionFreeText label = questionFreeTextWith label (pure ())

{- | Add a free-text textarea question with custom options. The respondent can
enter arbitrary text.

The second argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.
-}
questionFreeTextWith :: Text -> QuestionBuilder () -> FormBuilder ()
questionFreeTextWith questionText builder =
    addQuestion $ Question questionText QuestionFreeText (runQuestionBuilder builder)

{- | Add a regex-validated text input question with default options. The
respondent's answer must match the given POSIX extended regex pattern.

The first argument is the question label; the second is the regex pattern.
-}
questionRegexText :: Text -> Text -> FormBuilder ()
questionRegexText label regexPattern = questionRegexTextWith label regexPattern (pure ())

{- | Add a regex-validated text input question with custom options. The
respondent's answer must match the given POSIX extended regex pattern. The
pattern is also set as the HTML @pattern@ attribute for client-side
validation.

The first argument is the question label; the second is the regex pattern.
The third argument is a 'QuestionBuilder' block where you can configure
shared options such as 'setOptional'.

=== Example

@
questionRegexTextWith "SemVer number" "^v\\d+.\\d+.\\d+$" $ setOptional
@
-}
questionRegexTextWith :: Text -> Text -> QuestionBuilder () -> FormBuilder ()
questionRegexTextWith questionText regexPattern builder =
    addQuestion $ Question questionText (QuestionRegexText regexPattern) (runQuestionBuilder builder)