module Text.Digestive.Cli
( Prompt
, prompt
, promptList
, promptRead
, runPrompt
) where
import Data.Monoid (Monoid, mappend, mempty)
import Control.Applicative ((<$>))
import Text.Digestive.Result
import Text.Digestive.Types
import Text.Digestive.Transform
import Text.Digestive.Forms (inputList)
data FieldItem
= FieldItemSingle FormId String [String]
| FieldItemMultiStart FormId String [String]
| FieldItemMultiEnd
deriving (Show)
newtype PromptView = PromptView
{ unPromptView :: [FieldItem]
} deriving (Show, Monoid)
type Prompt a = Form IO String String PromptView a
newtype InputMap = InputMap
{ unInputMap :: [(FormId, String)]
} deriving (Show, Monoid)
inputMapEnvironment :: Monad m => InputMap -> Environment m String
inputMapEnvironment map' = Environment $ return . flip lookup (unInputMap map')
prompt :: String
-> Prompt String
prompt descr = Form $ do
id' <- getFormId
inp <- getFormInput
range <- getFormRange
let v :: [(FormRange, String)] -> PromptView
v errs = PromptView [FieldItemSingle id' descr matching]
where
matching = retainErrors range errs
result = case inp of
Just x -> Ok x
Nothing -> Error [(range, "No input")]
return (View v, result)
promptList :: String
-> Prompt a
-> Prompt [a]
promptList descr prmpt = Form $ do
id' <- getFormId
(v, r1) <- unForm $ inputList numPrompt (const prmpt) Nothing
range <- getFormRange
let vstart errs = PromptView [item]
where
item = FieldItemMultiStart id' descr $ retainErrors range errs
vend _ = PromptView [FieldItemMultiEnd]
return (View vstart `mappend` v `mappend` View vend, r1)
where
numPrompt _ = Form $ do
inp <- getFormInput
return (mempty, readN inp)
readN (Just x) = Ok (read x)
readN Nothing = Error []
promptRead :: Read a
=> String
-> String
-> Prompt a
promptRead error' descr = prompt descr `transform` transformRead error'
cliInput :: IO String
cliInput = putStr "> " >> getLine
inputForItems :: [FieldItem]
-> [(FormId, String)]
-> (FormId -> FormId)
-> IO ([FieldItem], [(FormId, String)])
inputForItems [] accum _fid = return ([], accum)
inputForItems (FieldItemMultiEnd : rest) accum _fid = return (rest, accum)
inputForItems (FieldItemSingle id' descr _errs : rest) accum fid = do
putStrLn descr
val <- cliInput
inputForItems rest ((fid id', val) : accum) fid
inputForItems (FieldItemMultiStart id' descr _errs : rest) accum fid = do
let id'' = fid id'
putStrLn $ "How many '" ++ descr ++ "' do you want to input?"
nStr <- cliInput
let f i = do putStrLn $ descr ++ " #" ++ show (i + 1) ++ ":"
inputForItems rest [] (modifyId id'' i)
delimited <- mapM f [0..(read nStr 1)]
let rest' = fst $ last delimited
countfield = (id'', nStr)
inputForItems rest' ([countfield] ++ accum ++ concatMap snd delimited) fid
modifyId :: FormId -> Integer -> FormId -> FormId
modifyId parent i = mapId (\x -> head x : i : formIdList parent)
runPrompt :: Prompt a
-> IO (Either [String] a)
runPrompt prmpt = do
prmptv <- viewForm prmpt "form"
inpmap <- InputMap . snd <$> inputForItems (unPromptView prmptv) [] id
eith <- eitherForm prmpt "form" (inputMapEnvironment inpmap)
return $ case eith of
Left v -> Left (fieldItemErrors `concatMap` unPromptView v)
Right x -> Right x
fieldItemErrors :: FieldItem -> [String]
fieldItemErrors (FieldItemSingle id' descr errs) =
descriptiveErrors id' descr errs
fieldItemErrors (FieldItemMultiStart id' descr errs) =
descriptiveErrors id' descr errs
fieldItemErrors FieldItemMultiEnd = []
descriptiveErrors :: FormId -> String -> [String] -> [String]
descriptiveErrors id' descr errs = map str errs
where
str err = "(" ++ show id' ++ ") " ++ descr ++ ": " ++ err