{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Users of the forms library should not need to use this module in general.
-- It is intended only for writing custom forms and form fields.
module Yesod.Form.Core
    ( FormResult (..)
    , GForm (..)
    , newFormIdent
    , deeperFormIdent
    , shallowerFormIdent
    , Env
    , FileEnv
    , Enctype (..)
    , Ints (..)
    , requiredFieldHelper
    , optionalFieldHelper
    , fieldsToInput
    , mapFormXml
    , checkForm
    , checkField
    , askParams
    , askFiles
    , liftForm
    , IsForm (..)
    , RunForm (..)
    , GFormMonad
      -- * Data types
    , FieldInfo (..)
    , FormFieldSettings (..)
    , FieldProfile (..)
      -- * Type synonyms
    , Form
    , Formlet
    , FormField
    , FormletField
    , FormInput
    ) where

import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Class (lift)
import Yesod.Handler
import Yesod.Widget
import Data.Monoid (Monoid (..))
import Control.Applicative
import Yesod.Request
import Control.Monad (liftM)
import Text.Hamlet
import Data.String
import Control.Monad (join)

-- | A form can produce three different results: there was no data available,
-- the data was invalid, or there was a successful parse.
--
-- The 'Applicative' instance will concatenate the failure messages in two
-- 'FormResult's.
data FormResult a = FormMissing
                  | FormFailure [String]
                  | FormSuccess a
    deriving Show
instance Functor FormResult where
    fmap _ FormMissing = FormMissing
    fmap _ (FormFailure errs) = FormFailure errs
    fmap f (FormSuccess a) = FormSuccess $ f a
instance Applicative FormResult where
    pure = FormSuccess
    (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
    (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
    (FormFailure x) <*> _ = FormFailure x
    _ <*> (FormFailure y) = FormFailure y
    _ <*> _ = FormMissing
instance Monoid m => Monoid (FormResult m) where
    mempty = pure mempty
    mappend x y = mappend <$> x <*> y

-- | The encoding type required by a form. The 'Show' instance produces values
-- that can be inserted directly into HTML.
data Enctype = UrlEncoded | Multipart
    deriving (Eq, Enum, Bounded)
instance ToHtml Enctype where
    toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"
    toHtml Multipart = unsafeByteString "multipart/form-data"
instance Monoid Enctype where
    mempty = UrlEncoded
    mappend UrlEncoded UrlEncoded = UrlEncoded
    mappend _ _ = Multipart

data Ints = IntCons Int Ints | IntSingle Int
instance Show Ints where
    show (IntSingle i) = show i
    show (IntCons i is) = show i ++ '-' : show is

incrInts :: Ints -> Ints
incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is

-- | A generic form, allowing you to specifying the subsite datatype, master
-- site datatype, a datatype for the form XML and the return type.
newtype GForm s m xml a = GForm
    { deform :: FormInner s m (FormResult a, xml, Enctype)
    }

type GFormMonad s m a = WriterT Enctype (FormInner s m) a

type FormInner s m =
    StateT Ints (
    ReaderT Env (
    ReaderT FileEnv (
    GHandler s m
    )))

type Env = [(String, String)]
type FileEnv = [(String, FileInfo)]

-- | Get a unique identifier.
newFormIdent :: Monad m => StateT Ints m String
newFormIdent = do
    i <- get
    let i' = incrInts i
    put i'
    return $ 'f' : show i'

deeperFormIdent :: Monad m => StateT Ints m ()
deeperFormIdent = do
    i <- get
    let i' = 1 `IntCons` incrInts i
    put i'

shallowerFormIdent :: Monad m => StateT Ints m ()
shallowerFormIdent = do
    IntCons _ i <- get
    put i

instance Monoid xml => Functor (GForm sub url xml) where
    fmap f (GForm g) =
        GForm $ liftM (first3 $ fmap f) g
      where
        first3 f' (x, y, z) = (f' x, y, z)

instance Monoid xml => Applicative (GForm sub url xml) where
    pure a = GForm $ return (pure a, mempty, mempty)
    (GForm f) <*> (GForm g) = GForm $ do
        (f1, f2, f3) <- f
        (g1, g2, g3) <- g
        return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)

-- | Create a required field (ie, one that cannot be blank) from a
-- 'FieldProfile'.
requiredFieldHelper
    :: IsForm f
    => FieldProfile (FormSub f) (FormMaster f) (FormType f)
    -> FormFieldSettings
    -> Maybe (FormType f)
    -> f
requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
    env <- lift ask
    let (FormFieldSettings label tooltip theId' name') = ffs
    name <- maybe newFormIdent return name'
    theId <- maybe newFormIdent return theId'
    let (res, val) =
            if null env
                then (FormMissing, maybe "" render orig)
                else case lookup name env of
                        Nothing -> (FormMissing, "")
                        Just "" -> (FormFailure ["Value is required"], "")
                        Just x ->
                            case parse x of
                                Left e -> (FormFailure [e], x)
                                Right y -> (FormSuccess y, x)
    let fi = FieldInfo
            { fiLabel = string label
            , fiTooltip = tooltip
            , fiIdent = theId
            , fiInput = mkWidget theId name val True
            , fiErrors = case res of
                            FormFailure [x] -> Just $ string x
                            _ -> Nothing
            , fiRequired = True
            }
    let res' = case res of
                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
                _ -> res
    return (res', fi, UrlEncoded)

class IsForm f where
    type FormSub f
    type FormMaster f
    type FormType f
    toForm :: FormInner
                (FormSub f)
                (FormMaster f)
                (FormResult (FormType f),
                 FieldInfo (FormSub f) (FormMaster f),
                 Enctype) -> f
instance IsForm (FormField s m a) where
    type FormSub (FormField s m a) = s
    type FormMaster (FormField s m a) = m
    type FormType (FormField s m a) = a
    toForm x = GForm $ do
        (a, b, c) <- x
        return (a, [b], c)
instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where
    type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s
    type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m
    type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a
    toForm x = do
        (res, fi, enctype) <- lift x
        tell enctype
        return (res, fi)

class RunForm f where
    type RunFormSub f
    type RunFormMaster f
    type RunFormType f
    runFormGeneric :: Env -> FileEnv -> f
                   -> GHandler (RunFormSub f)
                               (RunFormMaster f)
                               (RunFormType f)

instance RunForm (GForm s m xml a) where
    type RunFormSub (GForm s m xml a) = s
    type RunFormMaster (GForm s m xml a) = m
    type RunFormType (GForm s m xml a) =
        (FormResult a, xml, Enctype)
    runFormGeneric env fe (GForm f) =
        runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe

instance RunForm (GFormMonad s m a) where
    type RunFormSub (GFormMonad s m a) = s
    type RunFormMaster (GFormMonad s m a) = m
    type RunFormType (GFormMonad s m a) = (a, Enctype)
    runFormGeneric e fe f =
        runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe

-- | Create an optional field (ie, one that can be blank) from a
-- 'FieldProfile'.
optionalFieldHelper
    :: (IsForm f, Maybe b ~ FormType f)
    => FieldProfile (FormSub f) (FormMaster f) b
    -> FormFieldSettings
    -> Maybe (Maybe b)
    -> f
optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
    env <- lift ask
    let (FormFieldSettings label tooltip theId' name') = ffs
    let orig = join orig'
    name <- maybe newFormIdent return name'
    theId <- maybe newFormIdent return theId'
    let (res, val) =
            if null env
                then (FormSuccess Nothing, maybe "" render orig)
                else case lookup name env of
                        Nothing -> (FormSuccess Nothing, "")
                        Just "" -> (FormSuccess Nothing, "")
                        Just x ->
                            case parse x of
                                Left e -> (FormFailure [e], x)
                                Right y -> (FormSuccess $ Just y, x)
    let fi = FieldInfo
            { fiLabel = string label
            , fiTooltip = tooltip
            , fiIdent = theId
            , fiInput = mkWidget theId name val False
            , fiErrors = case res of
                            FormFailure x -> Just $ string $ unlines x
                            _ -> Nothing
            , fiRequired = False
            }
    let res' = case res of
                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
                _ -> res
    return (res', fi, UrlEncoded)

fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
fieldsToInput = map fiInput

-- | Convert the XML in a 'GForm'.
mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
mapFormXml f (GForm g) = GForm $ do
    (res, xml, enc) <- g
    return (res, f xml, enc)

-- | Using this as the intermediate XML representation for fields allows us to
-- write generic field functions and then different functions for producing
-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.
data FieldInfo sub y = FieldInfo
    { fiLabel :: Html
    , fiTooltip :: Html
    , fiIdent :: String
    , fiInput :: GWidget sub y ()
    , fiErrors :: Maybe Html
    , fiRequired :: Bool
    }

data FormFieldSettings = FormFieldSettings
    { ffsLabel :: String
    , ffsTooltip :: Html
    , ffsId :: Maybe String
    , ffsName :: Maybe String
    }
instance IsString FormFieldSettings where
    fromString s = FormFieldSettings s mempty Nothing Nothing

-- | A generic definition of a form field that can be used for generating both
-- required and optional fields. See 'requiredFieldHelper and
-- 'optionalFieldHelper'.
data FieldProfile sub y a = FieldProfile
    { fpParse :: String -> Either String a
    , fpRender :: a -> String
    -- | ID, name, value, required
    , fpWidget :: String -> String -> String -> Bool -> GWidget sub y ()
    }

type Form sub y = GForm sub y (GWidget sub y ())
type Formlet sub y a = Maybe a -> Form sub y a
type FormField sub y = GForm sub y [FieldInfo sub y]
type FormletField sub y a = Maybe a -> FormField sub y a
type FormInput sub y = GForm sub y [GWidget sub y ()]

-- | Add a validation check to a form.
--
-- Note that if there is a validation error, this message will /not/
-- automatically appear on the form; for that, you need to use 'checkField'.
checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b
checkForm f (GForm form) = GForm $ do
    (res, xml, enc) <- form
    let res' = case res of
                    FormSuccess a -> f a
                    FormFailure e -> FormFailure e
                    FormMissing -> FormMissing
    return (res', xml, enc)

-- | Add a validation check to a 'FormField'.
--
-- Unlike 'checkForm', the validation error will appear in the generated HTML
-- of the form.
checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b
checkField f (GForm form) = GForm $ do
    (res, xml, enc) <- form
    let (res', merr) =
            case res of
                FormSuccess a ->
                    case f a of
                        Left e -> (FormFailure [e], Just e)
                        Right x -> (FormSuccess x, Nothing)
                FormFailure e -> (FormFailure e, Nothing)
                FormMissing -> (FormMissing, Nothing)
    let xml' =
            case merr of
                Nothing -> xml
                Just err -> flip map xml $ \fi -> fi
                    { fiErrors = Just $
                        case fiErrors fi of
                            Nothing -> string err
                            Just x -> x
                    }
    return (res', xml', enc)

askParams :: Monad m => StateT Ints (ReaderT Env m) Env
askParams = lift ask

askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv
askFiles = lift $ lift ask

liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a
liftForm = lift . lift . lift