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