1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
module Main where
import Control.Applicative.Free
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State
import Data.Monoid (Sum(..))
import Text.Read (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 ++ "\"!"
|
