From e6503056a71e5f14ee0b5d44a37c40fa28048ee5 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 13 May 2011 08:52:41 +0300
Subject: [PATCH] Yesod.Form.Input

---
 Yesod/Form.hs       |  9 ++------
 Yesod/Form/Input.hs | 55 +++++++++++++++++++++++++++++++++++++++++++++
 Yesod/Form/Types.hs |  2 +-
 yesod-form.cabal    |  1 +
 4 files changed, 59 insertions(+), 8 deletions(-)
 create mode 100644 Yesod/Form/Input.hs

diff --git a/Yesod/Form.hs b/Yesod/Form.hs
index 7080ce67..4345e7da 100644
--- a/Yesod/Form.hs
+++ b/Yesod/Form.hs
@@ -1,19 +1,14 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
 -- | Parse forms (and query strings).
 module Yesod.Form
     ( module Yesod.Form.Types
     , module Yesod.Form.Functions
     , module Yesod.Form.Fields
     , module Yesod.Form.Class
+    , module Yesod.Form.Input
     ) where
 
 import Yesod.Form.Types
 import Yesod.Form.Functions
 import Yesod.Form.Fields
 import Yesod.Form.Class
+import Yesod.Form.Input
diff --git a/Yesod/Form/Input.hs b/Yesod/Form/Input.hs
new file mode 100644
index 00000000..8b4bf01c
--- /dev/null
+++ b/Yesod/Form/Input.hs
@@ -0,0 +1,55 @@
+{-# 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
diff --git a/Yesod/Form/Types.hs b/Yesod/Form/Types.hs
index 2d80fe43..ad0c5a58 100644
--- a/Yesod/Form/Types.hs
+++ b/Yesod/Form/Types.hs
@@ -66,7 +66,7 @@ instance Show Ints where
     show (IntSingle i) = show i
     show (IntCons i is) = show i ++ ('-' : show is)
 
-type Env = [(Text, Text)]
+type Env = [(Text, Text)] -- FIXME use a Map
 type FileEnv = [(Text, FileInfo)]
 
 type Form m a = RWST (Maybe (Env, FileEnv)) Enctype Ints m a
diff --git a/yesod-form.cabal b/yesod-form.cabal
index e8087dab..e92ef7d9 100644
--- a/yesod-form.cabal
+++ b/yesod-form.cabal
@@ -34,6 +34,7 @@ library
                      Yesod.Form.Class
                      Yesod.Form.Types
                      Yesod.Form.Functions
+                     Yesod.Form.Input
                      Yesod.Form.Fields
                      Yesod.Form.Jquery
                      Yesod.Form.Nic