{-# LANGUAGE CPP #-}
module Main where

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
#endif
import Control.Applicative.Free
import Control.Monad.State

import Data.Monoid (Sum(..))

import Text.Read.Compat (readEither)
import Text.Printf

import System.IO

-- | Field reader tries to read value or generates error message.
type FieldReader a = String -> Either String a

-- | Convenient synonym for field name.
type Name = String

-- | Convenient synonym for field help message.
type Help = String

-- | A single field of a form.
data Field a = Field
  { fName     :: Name           -- ^ Name.
  , fValidate :: FieldReader a  -- ^ Pure validation function.
  , fHelp     :: Help           -- ^ Help message.
  }

-- | Validation form is just a free applicative over Field.
type Form = Ap Field

-- | Build a form with a single field.
field :: Name -> FieldReader a -> Help -> Form a
field n f h = liftAp $ Field n f h

-- | Singleton form accepting any input.
string :: Name -> Help -> Form String
string n h = field n Right h

-- | Singleton form accepting anything but mentioned values.
available :: [String] -> Name -> Help -> Form String
available xs n h = field n check h
  where
    check x | x `elem` xs = Left "the value is not available"
            | otherwise   = Right x

-- | Singleton integer field form.
int :: Name -> Form Int
int name = field name readEither "an integer value"

-- | Generate help message for a form.
help :: Form a -> String
help = unlines . runAp_ (\f -> [fieldHelp f])

-- | Get help message for a field.
fieldHelp :: Field a -> String
fieldHelp (Field name _ msg) = printf "  %-15s - %s" name msg

-- | Count fields in a form.
count :: Form a -> Int
count = getSum . runAp_ (\_ -> Sum 1)

-- | Interactive input of a form.
-- Shows progress on each field.
-- Repeats field input until it passes validation.
-- Show help message on empty input.
input :: Form a -> IO a
input m = evalStateT (runAp inputField m) 1
  where
    inputField :: Field a -> StateT Int IO a
    inputField f@(Field n g h) = do
      i <- get
      -- get field input with prompt
      x <- liftIO $ do
        putStr $ printf "[%d/%d] %s: " i (count m) n
        hFlush stdout
        getLine
      case words x of
        -- display help message for empty input
        [] -> do
          liftIO . putStrLn $ "help: " ++ h
          inputField f
        -- validate otherwise
        _ -> case g x of
               Right y -> do
                 modify (+ 1)
                 return y
               Left  e -> do
                 liftIO . putStrLn $ "error: " ++ e
                 inputField f

-- | User datatype.
data User = User
  { userName     :: String
  , userFullName :: String
  , userAge      :: Int }
  deriving (Show)

-- | Form for User.
form :: [String] -> Form User
form us = User
  <$> available us  "Username"  "any vacant username"
  <*> string        "Full name" "your full name (e.g. John Smith)"
  <*> int           "Age"

main :: IO ()
main = do
  putStrLn "Creating a new user."
  putStrLn "Please, fill the form:"
  user <- input (form ["bob", "alice"])
  putStrLn $ "Successfully created user \"" ++ userName user ++ "\"!"