wizard.hs

{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE LambdaCase     #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE NamedFieldPuns   #-}
module Main where

import           Lucid.Base
import           Lucid.Html5

import           Control.Applicative.Free
import Control.Monad.Free
import           Data.Map.Strict          (Map)
import qualified Data.Map.Strict          as M
import           Data.Text                (Text)
import qualified Data.Text                as T
import qualified Data.Text.IO                as T
import           Text.Read                (readEither)

import           Control.Monad.State      (MonadState, gets, modify)
import Control.Monad.Except

tshow :: Show a => a -> Text
tshow = T.pack . show


type Name = Text
type Help = Text

type FieldReader a = String -> Either String a

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

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

renderField :: MonadState Int m => Field a -> HtmlT m ()
renderField Field{..} = do
  identifier <- mkIdentifier
  label_ (toHtml name) <> input_ [type_ "text", id_ identifier]

renderHelp :: Field a -> Text
renderHelp Field{..} = name <> "\n\n" <> help <> "\n"

queryField :: Field a -> ExceptT String IO a
queryField Field{..} = do
  liftIO $ T.putStrLn name
  ExceptT $ validate <$> liftIO getLine

mkIdentifier :: MonadState Int m => m Text
mkIdentifier = modify succ >> gets (mappend "input_" . tshow)

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"

type Form = Ap Field

strField :: FieldReader Text
strField = pure . T.pack

readField :: Read a => FieldReader a
readField = readEither

intField :: FieldReader Int
intField = readField

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)

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"

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)

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

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

main :: IO ()
main = do
  x <- foldFree evalWizard wizard
  print x