devforms-0.2.0.1: 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"]
        questionDateWith "When would you like to visit the zoo?" $ setOptional
        questionIntegerWith "How many tickets?" $ do
            setLowerBoundInclusive 1
            setUpperBoundInclusive 10
@
-}
module DevForms (
    ServerBuilder,
    FormBuilder,
    QuestionBuilder,
    IntegerQuestionBuilder,
    HasOptional (..),
    HasBounds (..),
    devFormServer,
    form,
    questionCheckbox,
    questionCheckboxWith,
    questionLikert,
    questionLikertWith,
    questionChoice,
    questionChoiceWith,
    questionDate,
    questionDateWith,
    questionTime,
    questionTimeWith,
    questionInteger,
    questionIntegerWith,
    questionFreeText,
    questionFreeTextWith,
    questionRegexText,
    questionRegexTextWith,
) where

import Control.Monad.Writer
import Form (Form (..), FormBuilder)
import Question (
    HasBounds (..),
    HasOptional (..),
    IntegerQuestionBuilder,
    Question (..),
    QuestionBuilder,
    QuestionType (..),
    runIntegerQuestionBuilder,
    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 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
an 'IntegerQuestionBuilder' 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 -> IntegerQuestionBuilder () -> FormBuilder ()
questionIntegerWith title builder =
    addQuestion $ Question title QuestionInteger (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)