{-# LANGUAGE OverloadedStrings #-}
module Yesod.Form.Input
    ( FormInput (..)
    , runInputGet
    , runInputPost
    , ireq
    , iopt
    ) where

import Yesod.Form.Types
import Data.Text (Text, append)
import Control.Applicative (Applicative (..))
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest)
import Yesod.Request (reqGetParams)
import Data.Maybe (fromMaybe)
import Control.Monad (liftM)

type DText = [Text] -> [Text]
newtype FormInput a = FormInput { unFormInput :: Env -> Either DText a }
instance Functor FormInput where
    fmap a (FormInput f) = FormInput $ \e -> either Left (Right . a) $ f e
instance Applicative FormInput where
    pure = FormInput . const . Right
    (FormInput f) <*> (FormInput x) = FormInput $ \e ->
        case (f e, x e) of
            (Left a, Left b) -> Left $ a . b
            (Left a, _) -> Left a
            (_, Left b) -> Left b
            (Right a, Right b) -> Right $ a b

ireq :: Field xml a -> Text -> FormInput a
ireq field name = FormInput $ \env ->
    case lookup name env of
        Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
        Just x -> either (Left . (:)) Right $ fieldParse field x

iopt :: Field xml a -> Text -> FormInput (Maybe a)
iopt field name = FormInput $ \env ->
    case fromMaybe "" $ lookup name env of
        "" -> Right Nothing
        x -> either (Left . (:)) (Right . Just) $ fieldParse field x

runInputGet :: Monad monad => FormInput a -> GGHandler sub master monad a
runInputGet (FormInput f) = do
    env <- liftM reqGetParams getRequest
    case f env of
        Left errs -> invalidArgs $ errs []
        Right x -> return x

runInputPost :: FormInput a -> GHandler sub master a
runInputPost (FormInput f) = do
    env <- liftM fst runRequestBody
    case f env of
        Left errs -> invalidArgs $ errs []
        Right x -> return x