1{-# LANGUAGE CPP #-}
2module Main where
3
4#if !(MIN_VERSION_base(4,8,0))
5import Control.Applicative
6#endif
7import Control.Applicative.Free
8import Control.Monad.State
9
10import Data.Monoid (Sum(..))
11
12import Text.Read.Compat (readEither)
13import Text.Printf
14
15import System.IO
16
17-- | Field reader tries to read value or generates error message.
18type FieldReader a = String -> Either String a
19
20-- | Convenient synonym for field name.
21type Name = String
22
23-- | Convenient synonym for field help message.
24type Help = String
25
26-- | A single field of a form.
27data Field a = Field
28  { fName     :: Name           -- ^ Name.
29  , fValidate :: FieldReader a  -- ^ Pure validation function.
30  , fHelp     :: Help           -- ^ Help message.
31  }
32
33-- | Validation form is just a free applicative over Field.
34type Form = Ap Field
35
36-- | Build a form with a single field.
37field :: Name -> FieldReader a -> Help -> Form a
38field n f h = liftAp $ Field n f h
39
40-- | Singleton form accepting any input.
41string :: Name -> Help -> Form String
42string n h = field n Right h
43
44-- | Singleton form accepting anything but mentioned values.
45available :: [String] -> Name -> Help -> Form String
46available xs n h = field n check h
47  where
48    check x | x `elem` xs = Left "the value is not available"
49            | otherwise   = Right x
50
51-- | Singleton integer field form.
52int :: Name -> Form Int
53int name = field name readEither "an integer value"
54
55-- | Generate help message for a form.
56help :: Form a -> String
57help = unlines . runAp_ (\f -> [fieldHelp f])
58
59-- | Get help message for a field.
60fieldHelp :: Field a -> String
61fieldHelp (Field name _ msg) = printf "  %-15s - %s" name msg
62
63-- | Count fields in a form.
64count :: Form a -> Int
65count = getSum . runAp_ (\_ -> Sum 1)
66
67-- | Interactive input of a form.
68-- Shows progress on each field.
69-- Repeats field input until it passes validation.
70-- Show help message on empty input.
71input :: Form a -> IO a
72input m = evalStateT (runAp inputField m) 1
73  where
74    inputField :: Field a -> StateT Int IO a
75    inputField f@(Field n g h) = do
76      i <- get
77      -- get field input with prompt
78      x <- liftIO $ do
79        putStr $ printf "[%d/%d] %s: " i (count m) n
80        hFlush stdout
81        getLine
82      case words x of
83        -- display help message for empty input
84        [] -> do
85          liftIO . putStrLn $ "help: " ++ h
86          inputField f
87        -- validate otherwise
88        _ -> case g x of
89               Right y -> do
90                 modify (+ 1)
91                 return y
92               Left  e -> do
93                 liftIO . putStrLn $ "error: " ++ e
94                 inputField f
95
96-- | User datatype.
97data User = User
98  { userName     :: String
99  , userFullName :: String
100  , userAge      :: Int }
101  deriving (Show)
102
103-- | Form for User.
104form :: [String] -> Form User
105form us = User
106  <$> available us  "Username"  "any vacant username"
107  <*> string        "Full name" "your full name (e.g. John Smith)"
108  <*> int           "Age"
109
110main :: IO ()
111main = do
112  putStrLn "Creating a new user."
113  putStrLn "Please, fill the form:"
114  user <- input (form ["bob", "alice"])
115  putStrLn $ "Successfully created user \"" ++ userName user ++ "\"!"
116
117