{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
{- |
This module defines the 'Form' type, its instances, core manipulation functions, and a bunch of helper utilities.
-}
module Text.Reform.Core where

import Control.Applicative         (Applicative(pure, (<*>)))
import Control.Applicative.Indexed (IndexedApplicative(ipure, (<<*>>)), IndexedFunctor (imap))
import Control.Arrow               (first, second)
import Control.Monad.Reader        (MonadReader(ask), ReaderT, runReaderT)
import Control.Monad.State         (MonadState(get,put), StateT, evalStateT)
import Control.Monad.Trans         (lift)
import Data.Monoid                 (Monoid(mempty, mappend))
import qualified Data.Semigroup    as SG
import Data.Text.Lazy              (Text, unpack)
import Text.Reform.Result          (FormId(..), FormRange(..), Result(..), unitRange, zeroId)

------------------------------------------------------------------------------
-- * Proved
------------------------------------------------------------------------------

-- | Proved records a value, the location that value came from, and something that was proved about the value.
data Proved proofs a =
    Proved { proofs   :: proofs
           , pos      :: FormRange
           , unProved :: a
           }
    deriving Show

instance Functor (Proved ()) where
    fmap f (Proved () pos a) = Proved () pos (f a)

-- | Utility Function: trivially prove nothing about ()
unitProved :: FormId -> Proved () ()
unitProved formId =
    Proved { proofs   = ()
           , pos      = unitRange formId
           , unProved = ()
           }

------------------------------------------------------------------------------
-- * FormState
------------------------------------------------------------------------------

-- | inner state used by 'Form'.
type FormState m input = ReaderT (Environment m input) (StateT FormRange m)

-- | used to represent whether a value was found in the form
-- submission data, missing from the form submission data, or expected
-- that the default value should be used
data Value a
    = Default
    | Missing
    | Found a

-- | Utility function: Get the current input
--
getFormInput :: Monad m => FormState m input (Value input)
getFormInput = getFormId >>= getFormInput'

-- | Utility function: Gets the input of an arbitrary 'FormId'.
--
getFormInput' :: Monad m => FormId -> FormState m input (Value input)
getFormInput' id' = do
    env <- ask
    case env of
      NoEnvironment -> return Default
      Environment f ->
          lift $ lift $ f id'

-- | Utility function: Get the current range
--
getFormRange :: Monad m => FormState m i FormRange
getFormRange = get

-- | The environment is where you get the actual input per form.
--
-- The 'NoEnvironment' constructor is typically used when generating a
-- view for a GET request, where no data has yet been submitted. This
-- will cause the input elements to use their supplied default values.
--
-- Note that 'NoEnviroment' is different than supplying an empty environment.
data Environment m input
    = Environment (FormId -> m (Value input))
    | NoEnvironment

instance (SG.Semigroup input, Monad m) => SG.Semigroup (Environment m input) where
    NoEnvironment <> x = x
    x <> NoEnvironment = x
    (Environment env1) <> (Environment env2) =
        Environment $ \id' ->
            do r1 <- (env1 id')
               r2 <- (env2 id')
               case (r1, r2) of
                 (Missing, Missing) -> return Missing
                 (Default, Missing) -> return Default
                 (Missing, Default) -> return Default
                 (Found x, Found y) -> return $ Found (x SG.<> y)
                 (Found x, _      ) -> return $ Found x
                 (_      , Found y) -> return $ Found y

-- | Not quite sure when this is useful and so hard to say if the rules for combining things with Missing/Default are correct
instance (SG.Semigroup input, Monad m) => Monoid (Environment m input) where
    mempty = NoEnvironment
    mappend = (SG.<>)

-- | Utility function: returns the current 'FormId'. This will only make sense
-- if the form is not composed
--
getFormId :: Monad m => FormState m i FormId
getFormId = do
    FormRange x _ <- get
    return x

-- | Utility function: increment the current 'FormId'.
incFormId :: Monad m => FormState m i ()
incFormId = do
        FormRange _ endF1 <- get
        put $ unitRange endF1

-- | A view represents a visual representation of a form. It is composed of a
-- function which takes a list of all errors and then produces a new view
--
newtype View error v = View
    { unView :: [(FormRange, error)] -> v
    } deriving (SG.Semigroup, Monoid)

instance Functor (View e) where
    fmap f (View g) = View $ f . g

------------------------------------------------------------------------------
-- * Form
------------------------------------------------------------------------------

-- | a 'Form' contains a 'View' combined with a validation function
-- which will attempt to extract a value from submitted form data.
--
-- It is highly parameterized, allowing it work in a wide variety of
-- different configurations. You will likely want to make a type alias
-- that is specific to your application to make type signatures more
-- manageable.
--
--   [@m@] A monad which can be used by the validator
--
--   [@input@] A framework specific type for representing the raw key/value pairs from the form data
--
--   [@error@] A application specific type for error messages
--
--   [@view@] The type of data being generated for the view (HSP, Blaze Html, Heist, etc)
--
--   [@proof@] A type which names what has been proved about the return value. @()@ means nothing has been proved.
--
--   [@a@] Value return by form when it is successfully decoded, validated, etc.
--
--
-- This type is very similar to the 'Form' type from
-- @digestive-functors <= 0.2@. If @proof@ is @()@, then 'Form' is an
-- applicative functor and can be used almost exactly like
-- @digestive-functors <= 0.2@.
newtype Form m input error view proof a = Form { unForm :: FormState m input (View error view, m (Result error (Proved proof a))) }

instance (Monad m) => IndexedFunctor (Form m input view error) where
    imap f g (Form frm) =
        Form $ do (view, mval) <- frm
                  val <- lift $ lift $ mval
                  case val of
                    (Ok (Proved p pos a)) -> return (view, return $ Ok (Proved (f p) pos (g a)))
                    (Error errs)          -> return (view, return $ Error errs)

instance (Monoid view, Monad m) => IndexedApplicative (Form m input error view) where
    ipure p a = Form $ do i <- getFormId
                          return (mempty, return $ Ok (Proved p (unitRange i) a))

    (Form frmF) <<*>> (Form frmA) =
        Form $ do ((view1, mfok), (view2, maok)) <- bracketState $
                    do res1 <- frmF
                       incFormId
                       res2 <- frmA
                       return (res1, res2)
                  fok <- lift $ lift $ mfok
                  aok <- lift $ lift $ maok
                  case (fok, aok) of
                     (Error errs1, Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs1 ++ errs2)
                     (Error errs1, _)           -> return (view1 `mappend` view2, return $ Error $ errs1)
                     (_          , Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs2)
                     (Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) ->
                         return (view1 `mappend` view2, return $ Ok $ Proved { proofs   = p q
                                                                           , pos      = FormRange x y
                                                                           , unProved = f a
                                                                           })

bracketState :: Monad m => FormState m input a -> FormState m input a
bracketState k = do
    FormRange startF1 _ <- get
    res <- k
    FormRange _ endF2 <- get
    put $ FormRange startF1 endF2
    return res


instance (Functor m) => Functor (Form m input error view ()) where
    fmap f form =
        Form $ fmap (second (fmap (fmap (fmap f)))) (unForm form)


instance (Functor m, Monoid view, Monad m) => Applicative (Form m input error view ()) where
    pure a =
      Form $
        do i <- getFormId
           return (View $ const $ mempty, return $ Ok $ Proved { proofs    = ()
                                                               , pos       = FormRange i i
                                                               , unProved  = a
                                                               })
    -- this coud be defined in terms of <<*>> if we just changed the proof of frmF to (() -> ())
    (Form frmF) <*> (Form frmA) =
       Form $
         do ((view1, mfok), (view2, maok)) <- bracketState $
              do res1 <- frmF
                 incFormId
                 res2 <- frmA
                 return (res1, res2)
            fok <- lift $ lift $ mfok
            aok <- lift $ lift $ maok
            case (fok, aok) of
              (Error errs1, Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs1 ++ errs2)
              (Error errs1, _)           -> return (view1 `mappend` view2, return $ Error $ errs1)
              (_          , Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs2)
              (Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) ->
                  return (view1 `mappend` view2, return $ Ok $ Proved { proofs   = ()
                                                                      , pos      = FormRange x y
                                                                      , unProved = f a
                                                                      })

-- ** Ways to evaluate a Form

-- | Run a form
--
runForm :: (Monad m) =>
           Environment m input
        -> Text
        -> Form m input error view proof a
        -> m (View error view, m (Result error (Proved proof a)))
runForm env prefix' form =
    evalStateT (runReaderT (unForm form) env) (unitRange (zeroId $ unpack prefix'))

-- | Run a form
--
runForm' :: (Monad m) =>
            Environment m input
         -> Text
        -> Form m input error view proof a
        -> m (view , Maybe a)
runForm' env prefix form =
    do (view', mresult) <- runForm env prefix form
       result <- mresult
       return $ case result of
                  Error e  -> (unView view' e , Nothing)
                  Ok x     -> (unView view' [], Just (unProved x))

-- | Just evaluate the form to a view. This usually maps to a GET request in the
-- browser.
--
viewForm :: (Monad m) =>
            Text                          -- ^ form prefix
         -> Form m input error view proof a -- ^ form to view
         -> m view
viewForm prefix form =
    do (v, _) <- runForm NoEnvironment prefix form
       return (unView v [])

-- | Evaluate a form
--
-- Returns:
--
-- [@Left view@] on failure. The @view@ will have already been applied to the errors.
--
-- [@Right a@] on success.
--
eitherForm :: (Monad m) =>
              Environment m input             -- ^ Input environment
           -> Text                          -- ^ Identifier for the form
           -> Form m input error view proof a -- ^ Form to run
           -> m (Either view a)               -- ^ Result
eitherForm env id' form = do
    (view', mresult) <- runForm env id' form
    result <- mresult
    return $ case result of
        Error e  -> Left $ unView view' e
        Ok x     -> Right (unProved x)

-- | create a 'Form' from some @view@.
--
-- This is typically used to turn markup like @\<br\>@ into a 'Form'.
view :: (Monad m) =>
        view                           -- ^ View to insert
     -> Form m input error view () ()  -- ^ Resulting form
view view' =
  Form $
    do i <- getFormId
       return ( View (const view')
              , return (Ok (Proved { proofs   = ()
                                   , pos      = FormRange i i
                                   , unProved = ()
                                   })))

-- | Append a unit form to the left. This is useful for adding labels or error
-- fields.
--
-- The 'Forms' on the left and right hand side will share the same
-- 'FormId'. This is useful for elements like @\<label
-- for=\"someid\"\>@, which need to refer to the id of another
-- element.
(++>) :: (Monad m, Monoid view)
      => Form m input error view () ()
      -> Form m input error view proof a
      -> Form m input error view proof a
f1 ++> f2 = Form $ do
    -- Evaluate the form that matters first, so we have a correct range set
    (v2, r) <- unForm f2
    (v1, _) <- unForm f1
    return (v1 `mappend` v2, r)

infixl 6 ++>

-- | Append a unit form to the right. See '++>'.
--
(<++) :: (Monad m, Monoid view)
      => Form m input error view proof a
      -> Form m input error view () ()
      -> Form m input error view proof a
f1 <++ f2 = Form $ do
    -- Evaluate the form that matters first, so we have a correct range set
    (v1, r) <- unForm f1
    (v2, _) <- unForm f2
    return (v1 `mappend` v2, r)

infixr 5 <++

-- | Change the view of a form using a simple function
--
-- This is useful for wrapping a form inside of a \<fieldset\> or other markup element.
mapView :: (Monad m, Functor m)
        => (view -> view')        -- ^ Manipulator
        -> Form m input error view  proof a  -- ^ Initial form
        -> Form m input error view' proof a  -- ^ Resulting form
mapView f = Form . fmap (first $ fmap f) . unForm

-- | Utility Function: turn a view and return value into a successful 'FormState'
mkOk :: (Monad m) =>
         FormId
      -> view
      -> a
      -> FormState m input (View error view, m (Result error (Proved () a)))
mkOk i view val =
    return ( View $ const $ view
           , return $ Ok (Proved { proofs   = ()
                                 , pos      = unitRange i
                                 , unProved = val
                                 })
           )