    {-# LANGUAGE ScopedTypeVariables, TypeFamilies, ViewPatterns #-}
    {- |
    This module provides helper functions for HTML input elements. These helper functions are not specific to any particular web framework or html library.
    -}
    module Text.Reform.Generalized where

    import Control.Applicative    ((<$>))
    import qualified Data.IntSet  as IS
    import Data.List              (find)
    import Data.Maybe             (mapMaybe)
    import Numeric                (readDec)
    import Text.Reform.Backend
    import Text.Reform.Core
    import Text.Reform.Result

    -- | used for constructing elements like @\<input type=\"text\"\>@, which return a single input value.
    input :: (Monad m, FormError error) =>
             (input -> Either error a)
          -> (FormId -> a -> view)
          -> a
          -> Form m input error view () a
    input fromInput toView initialValue =
        Form $ do i <- getFormId
                  v <- getFormInput' i
                  case v of
                    Default ->
                        return ( View $ const $ toView i initialValue
                               , return $ Ok (Proved { proofs   = ()
                                                     , pos      = unitRange i
                                                     , unProved = initialValue
                                                     }))
                    (Found (fromInput -> (Right a))) ->
                        return ( View $ const $ toView i a
                               , return $ Ok (Proved { proofs   = ()
                                                     , pos      = unitRange i
                                                     , unProved = a
                                                     }))
                    (Found (fromInput -> (Left error))) ->
                        return ( View $ const $ toView i initialValue
                               , return $ Error [(unitRange i, error)]
                               )
                    Missing ->
                        return ( View $ const $ toView i initialValue
                               , return $ Error [(unitRange i, commonFormError (InputMissing i))]
                               )

    -- | used for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data.
    inputMaybe :: (Monad m, FormError error) =>
             (input -> Either error a)
          -> (FormId -> a -> view)
          -> a
          -> Form m input error view () (Maybe a)
    inputMaybe fromInput toView initialValue =
        Form $ do i <- getFormId
                  v <- getFormInput' i
                  case v of
                    Default ->
                        return ( View $ const $ toView i initialValue
                               , return $ Ok (Proved { proofs   = ()
                                                     , pos      = unitRange i
                                                     , unProved = Just initialValue
                                                     }))
                    (Found (fromInput -> (Right a))) ->
                        return ( View $ const $ toView i a
                               , return $ Ok (Proved { proofs   = ()
                                                     , pos      = unitRange i
                                                     , unProved = (Just a)
                                                     }))
                    (Found (fromInput -> (Left error))) ->
                        return ( View $ const $ toView i initialValue
                               , return $ Error [(unitRange i, error)]
                               )
                    Missing ->
                        return ( View $ const $ toView i initialValue
                               , return $ Ok (Proved { proofs   = ()
                                                     , pos      = unitRange i
                                                     , unProved = Nothing
                                                     })
                               )

    -- | used for elements like @\<input type=\"reset\"\>@ which take a value, but are never present in the form data set.
    inputNoData :: (Monad m) =>
                  (FormId -> a -> view)
               -> a
               -> Form m input error view () ()
    inputNoData toView a =
        Form $ do i <- getFormId
                  return ( View $ const $ toView i a
                         , return $ Ok (Proved { proofs   = ()
                                               , pos      = unitRange i
                                               , unProved = ()
                                               })
                         )

    -- | used for @\<input type=\"file\"\>@
    inputFile :: forall m input error view. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input) =>
                 (FormId -> view)
              -> Form m input error view () (FileType input)
    inputFile toView =
        Form $ do i <- getFormId
                  v <- getFormInput' i
                  case v of
                    Default ->
                        return ( View $ const $ toView i
                               , return $ Error [(unitRange i, commonFormError (InputMissing i))]
                               )

                    (Found (getInputFile' -> (Right a))) ->
                        return ( View $ const $ toView i
                               , return $ Ok (Proved { proofs   = ()
                                                     , pos      = unitRange i
                                                     , unProved = a
                                                     }))

                    (Found (getInputFile' -> (Left error))) ->
                        return ( View $ const $ toView i
                               , return $ Error [(unitRange i, error)]
                               )
                    Missing ->
                        return ( View $ const $ toView i
                               , return $ Error [(unitRange i, commonFormError (InputMissing i))]
                               )
            where
              -- just here for the type-signature to make the type-checker happy
              getInputFile' :: (FormError error, ErrorInputType error ~ input) => input -> Either error (FileType input)
              getInputFile' = getInputFile

    -- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes
    inputMulti :: forall m input error view a lbl. (Functor m, FormError error, ErrorInputType error ~ input, FormInput input, Monad m) =>
                  [(a, lbl)]                                      -- ^ value, label, initially checked
               -> (FormId -> [(FormId, Int, lbl, Bool)] -> view)  -- ^ function which generates the view
               -> (a -> Bool)                                     -- ^ isChecked/isSelected initially
               -> Form m input error view () [a]
    inputMulti choices mkView isSelected =
        Form $ do i <- getFormId
                  inp <- getFormInput' i
                  case inp of

                    Default ->
                        do let (choices', vals) = foldr (\(a, lbl) (cs,vs) ->
                                                             if isSelected a
                                                             then ((a, lbl, True) :cs, a:vs)
                                                             else ((a, lbl, False):cs,   vs))
                                                        ([],[])
                                                        choices
                           view     <- mkView i <$> augmentChoices choices'
                           mkOk i view vals

                    Missing -> -- just means that no checkboxes were checked
                         do view <- mkView i <$> augmentChoices (map (\(x,y) -> (x,y,False)) choices)
                            mkOk i view []

                    (Found v) ->
                        do let readDec' str = case readDec str of
                                                [(n,[])] -> n
                                                _ -> (-1) -- FIXME: should probably return an internal error?
                               keys   = IS.fromList $ map readDec' $ getInputStrings v
                               (choices', vals) =
                                   foldr (\(i, (a,lbl)) (c,v) ->
                                              if IS.member i keys
                                              then ((a,lbl,True) : c, a : v)
                                              else ((a,lbl,False): c,     v)) ([],[]) $
                                     zip [0..] choices
                           view <- mkView i <$> augmentChoices choices'
                           mkOk i view vals

        where
          augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]
          augmentChoices choices = mapM augmentChoice (zip [0..] choices)

          augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)
          augmentChoice (vl, (a, lbl, checked)) =
              do i <- getFormId
                 return (i, vl, lbl, checked)

    -- | radio buttons, single @\<select\>@ boxes
    inputChoice :: forall a m error input lbl view. (Functor m, FormError error, ErrorInputType error ~ input, FormInput input, Monad m) =>
                   (a -> Bool)                                     -- ^ is default
                -> [(a, lbl)]                                      -- ^ value, label
                -> (FormId -> [(FormId, Int, lbl, Bool)] -> view)  -- ^ function which generates the view
                -> Form m input error view () a
    inputChoice isDefault choices mkView =
        Form $ do i <- getFormId
                  inp <- getFormInput' i

                  case inp of
                    Default ->
                        do let (choices', def) = markSelected choices
                           view <- mkView i <$> augmentChoices choices'
                           mkOk' i view def

                    Missing -> -- can happen if no choices where checked
                        do let (choices', def) = markSelected choices
                           view <- mkView i <$> augmentChoices choices'
                           mkOk' i view def

                    (Found v) ->
                        do let readDec' str = case readDec str of
                                                [(n,[])] -> n
                                                _ -> (-1) -- FIXME: should probably return an internal error?
                               (Right str) = getInputString v :: Either error String -- FIXME
                               key = readDec' str
                               (choices', mval) =
                                   foldr (\(i, (a, lbl)) (c, v) ->
                                              if i == key
                                              then ((a,lbl,True) : c, Just a)
                                              else ((a,lbl,False): c,     v))
                                         ([], Nothing) $
                                         zip [0..] choices
                           view <- mkView i <$> augmentChoices choices'
                           case mval of
                             Nothing ->
                                 return ( View $ const $ view
                                        , return $ Error [(unitRange i, commonFormError (InputMissing i))]
                                        )
                             (Just val) -> mkOk i view val

        where
          mkOk' i view (Just val) = mkOk i view val
          mkOk' i view Nothing =
              return ( View $ const $ view
                     , return $ Error [(unitRange i, commonFormError MissingDefaultValue)]
                     )

          markSelected :: [(a,lbl)] -> ([(a, lbl, Bool)], Maybe a)
          markSelected cs = foldr (\(a,lbl) (vs, ma) ->
                                       if isDefault a
                                          then ((a,lbl,True):vs , Just a)
                                          else ((a,lbl,False):vs, ma))
                             ([], Nothing)
                             cs

          augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]
          augmentChoices choices = mapM augmentChoice (zip [0..] choices)

          augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)
          augmentChoice (vl, (a, lbl,selected)) =
              do i <- getFormId
                 return (i, vl, lbl, selected)

    -- | used to create @\<label\>@ elements
    label :: Monad m =>
             (FormId -> view)
          -> Form m input error view () ()
    label f = Form $ do
        id' <- getFormId
        return ( View (const $ f id')
               , return (Ok $ Proved { proofs   = ()
                                     , pos      = unitRange id'
                                     , unProved = ()
                                     })
               )
    -- | used to add a list of error messages to a 'Form'
    --
    -- This function automatically takes care of extracting only the
    -- errors that are relevent to the form element it is attached to via
    -- '<++' or '++>'.
    errors :: Monad m =>
              ([error] -> view) -- ^ function to convert the error messages into a view
           -> Form m input error view () ()
    errors f = Form $ do
        range <- getFormRange
        return ( View (f . retainErrors range)
               , return (Ok $ Proved { proofs   = ()
                                     , pos      = range
                                     , unProved = ()
                                     })
               )

    -- | similar to 'errors' but includes error messages from children of the form as well.
    childErrors :: Monad m =>
                   ([error] -> view)
                -> Form m input error view () ()
    childErrors f = Form $ do
        range <- getFormRange
        return (View (f . retainChildErrors range)
               , return (Ok $ Proved { proofs   = ()
                                     , pos      = range
                                     , unProved = ()
                                     })
               )