{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Survey.Pages.EditSurvey where

import Control.Applicative (Applicative((<*>),pure), Alternative, (*>), (<*), (<$>))
import Control.Monad
import Control.Monad.Trans (MonadIO(..))
import Data.Acid
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Happstack.Server
import HSP
import qualified HSX.XMLGenerator as HSX
import Survey.Types
import Survey.State (SurveyState, NewItemToSurvey(..), surveyError)
import Survey.Pages.FormPart
import qualified Survey.URL as URL
import Text.Digestive
import Text.Digestive.Common (input)
import Text.Digestive.Forms (FormInput(..))
import qualified Text.Digestive.Forms as Forms
import Text.Digestive.Forms.Happstack
import Text.Digestive.HSP.Html4 hiding (inputTextArea)
import Web.Routes

editSurveyPage :: (EmbedAsAttr m (Attr String URL.SurveyURL), EmbedAsChild m XML, URL m ~ URL.SurveyURL, XMLGenerator m) =>
                  (String -> [XMLGenT m (HSX.XML m)] -> XMLGenT m (HSX.XML m) -> m Response)
               -> SurveyId
               -> m Response
                  
editSurveyPage pageTemplate sid =
    do pageTemplate "Edit Survey" [] $
          <div>
           <h2>Edit Survey</h2>
           <p>Survey <% show $ unSurveyId $ sid %></p>
           <p>Add a question with an answer that is:</p>
           <p>Add <a href=(URL.AddItem sid URL.TrueFalse)>True / False</a></p>
           <p>Add <a href=(URL.AddItem sid URL.RangeInt)>Integer Range</a></p>
           <p>Add <a href=(URL.AddItem sid URL.SingleLine)>Single Line</a></p>
           <p>Add <a href=(URL.AddItem sid URL.LongResponse)>Long Response</a></p>
           <p>Add <a href=(URL.AddItem sid URL.PickOne)>Pick One</a></p>
           <p>Add <a href=(URL.AddItem sid URL.PickMany)>Pick Many</a></p>
          </div>

itemFormPage ::
    (Alternative m, Happstack m, XMLGenerator m, Functor m, URL m ~ URL.SurveyURL, ShowURL m, EmbedAsChild m XML, EmbedAsAttr m (Attr String URL.SurveyURL)) =>
    (String -> [XMLGenT m (HSX.XML m)] -> XMLGenT m (HSX.XML m) -> m Response) 
    -> AcidState SurveyState
    -> URL.SurveyURL
    -> SurveyId
    -> Form (XMLGenT m) [Input] String [XMLGenT m (HSX.XML m)] Choices
    -> m Response
itemFormPage pageTemplate acid here sid choicesForm =
    do actionURL <- showURL here
       pageTemplate "Edit Survey" [<script type="text/javascript"><% pcdata inputListJs %></script>] $
          <div>
           <h2>Add Item</h2>
           <p>Survey <% show $ unSurveyId $ sid %></p>
           <% formPart "survey" actionURL addItem Nothing ((,) <$> questionForm <*> choicesForm <* submit "add survey item")  %>
          </div>
    where
      addItem (q,c) =
          do r <- update' acid (NewItemToSurvey sid q c)
             case r of
               (Left e) -> do internalServerError ()
                              pageTemplate "Internal Error" [] <p><% surveyError e %></p>
               (Right item) ->
                   pageTemplate "Item Added" []
                                <div>
                                 <p>Item successfully added. <% show item %></p>
                                 <p><a href=(URL.EditSurvey sid)>Continue editing</a></p>
                                </div>

inputInt :: (Functor m, Monad m, XMLGenerator x) => Maybe Int -> Form m [Input] String [XMLGenT x (HSX.XML x)] Int
inputInt i = 
    (inputString (fmap show i) `transform`
     (transformEither (\str -> case reads str of
                                 [(i,"")] -> Right i
                                 _ -> Left $ "Could not parse as Int: " ++ str)))

questionForm :: (XMLGenerator x, Functor m, Monad m) =>
                Form m [Input] String [XMLGenT x (HSX.XML x)] Question
questionForm =
    label "Enter the question: " ++> (QuestionText <$> inputText Nothing)

trueFalseForm :: (XMLGenerator x, Functor m, Monad m) =>
                Form m [Input] String [XMLGenT x (HSX.XML x)] Choices
trueFalseForm =
    label "true / false" ++> pure ChoiceTrueFalse

-- FIXME: add validation
rangeIntForm :: (XMLGenerator x, Functor m, Monad m) =>
                Form m [Input] String [XMLGenT x (HSX.XML x)] Choices
rangeIntForm =
    (ChoiceRangeInt <$> (label "min" ++> inputInt Nothing)
                        <*> (label "max" ++> inputInt Nothing))

longResponseForm :: (XMLGenerator x, Functor m, Monad m) =>
                Form m [Input] String [XMLGenT x (HSX.XML x)] Choices
longResponseForm =
    pure $ ChoiceLongResponse (Just 80) (Just 20)

singleLineForm :: (XMLGenerator x, Functor m, Monad m) =>
                Form m [Input] String [XMLGenT x (HSX.XML x)] Choices
singleLineForm =
    pure $ ChoiceSingleLine Nothing

pickOneForm :: (XMLGenerator x, Functor m, Monad m) =>
               Form m [Input] String [XMLGenT x (HSX.XML x)] Choices
pickOneForm =
    ChoicePickOne Text.empty <$> ((inputList inputHiddenInt inputText) Nothing)

pickManyForm :: (XMLGenerator x, Functor m, Monad m) =>
               Form m [Input] String [XMLGenT x (HSX.XML x)] Choices
pickManyForm =
    ChoicePickMany [] <$> ((inputList inputHiddenInt inputText) Nothing)

-- move to digestive-functors-hsp

required :: (Monad m) => e -> Transformer m e (Maybe a) a
required err = transformEither $ maybe (Left err) Right

inputTextArea :: (Monad m, Functor m, EmbedAsAttr x (Attr Text Int), EmbedAsChild x Text, XMLGenerator x, FormInput i f) =>
                 Maybe Int
              -> Maybe Int
              -> Maybe Text
              -> Form m i e [XMLGenT x (HSX.XML x)] Text
inputTextArea r c = 
    inputText' $ \id' inp ->
        [<textarea name=(showFormId id') id=(showFormId id') (rows r ++ cols c)><% fromMaybe Text.empty inp %></textarea>]
    where
      rows Nothing  = []
      rows (Just n) = [(Text.pack "rows" := n)]
      cols Nothing  = []
      cols (Just n) = [(Text.pack "cols" := n)]

inputText' :: (Monad m, Functor m, FormInput i f)
            => (FormId -> Maybe Text -> v)  -- ^ View constructor
            -> Maybe Text                   -- ^ Default value
            -> Form m i e v Text            -- ^ Resulting form
inputText' = input toView toResult
  where
    toView _ inp def = (getInputText =<< inp) `mplus` def
    toResult = Ok . fromMaybe Text.empty . (getInputText =<<)



inputHiddenInt :: (Monad m, Functor m, XMLGenerator x, FormInput i f)
               => Formlet m i String [XMLGenT x (HSX.XML x)] Int
inputHiddenInt i =
    hiddenString (fmap show i) `transform` (transformRead "inputHiddenInt could not parse form value as an Int")

hiddenString :: (Monad m, Functor m, XMLGenerator x, FormInput i f)
          => Maybe String
          -> Form m i e [XMLGenT x (HSX.XML x)] String
hiddenString str = 
    Forms.inputString
             (\id' inp ->
                  [<input type="hidden" name=(show id') id=(show id') value=(fromMaybe "" inp) />])
             str


-- inputList

-- | Wraps the more generic 'Text.Digestive.Forms.inputList' function to
-- provide a reasonable default for adding add/remove controls to a form.
-- The whole thing is wrapped in another div with the class inputList.  For
-- this function to work, the javascript code in 'inputListJs' or something
-- similar must be in scope.
--
-- The user needs to specify the hidden formlet because transformRead requires
-- an error parameter, and this function can't specify it without loss of
-- generality.  The idea is that the extra power of being able to customize
-- the formlet is worth the small amount of extra code compared to having to
-- specify the error.
--
inputList :: (XMLGenerator x, Monad m, Functor m, FormInput i f)
          => Formlet m i e [XMLGenT x (HSX.XML x)] Int
          -- ^ The formlet holding the number of items in the list
          -> Formlet m i e [XMLGenT x (HSX.XML x)]  a
          -- ^ The formlet used for each list item.  This function surrounds it
          -- with a div tag with the inputListItem class.
          -> Formlet m i e [XMLGenT x (HSX.XML x)] [a]
          -- ^ The dynamic list formlet
inputList hidden single d =
    mapView addControls $ Forms.inputList hidden s d
  where
    s def =  mapView (\i -> [<div class="inputListItem"><% i %></div>]) $ single def
    addControls form =
      [<div class="inputList">
        <div>
         <input type="button" onclick="addItem(this);    return false;" value="Add Item" />
         <input type="button" onclick="removeItem(this); return false;" value="Remove Item" />
         <% form %>
        </div>
       </div>
      ]
--    s def = mapView (fmap (H.div ! A.class_ "inputListItem")) $ single def
--    - def =  mapView (fmap (H.div ! A.class_ "inputListItem")) $ single def
{-
    addControls form = do
        H.div ! A.class_ "inputList" $ do
            H.div $ do
                H.input ! A.type_ "button"
                        ! A.onclick "addItem(this); return false;"
                        ! A.value "Add Item"
                H.input ! A.type_ "button"
                        ! A.onclick "removeItem(this); return false;"
                        ! A.value "Remove Item"
            form
-}

-- | A string containing the javascript functions needed for inputList.  This
-- code requires JQuery.
--
inputListJs :: String
inputListJs = unlines
    ["// Requires that JQuery also be in scope"
    ,"function findInputList(button) {"
    ,"  var mainDiv = $(button).parent();"
    ,"  while ( !mainDiv.hasClass('inputList') ) {"
    ,"    mainDiv = $(mainDiv).parent();"
    ,"  }"
    ,"  return mainDiv;"
    ,"}"
    ,""
    ,"function findItems(button) {"
    ,"  return $('.inputListItem', findInputList(button));"
    ,"}"
    ,""
    ,"function addItem(button) {"
    ,"  var count = $(':hidden', findInputList(button))[0];"
    ,"  var items = findItems(button);"
    ,"  var item = $(items[items.length-1]);"
    ,"  var newItem = item.clone(true);"
    ,"  var i;"
    ,""
    ,"  // Increment counter"
    ,"  $(count).val(parseInt($(count).val())+1);"
    ,""
    ,"  // We have to change the raw html because IE doesn't allow the"
    ,"  // name field to be changed."
    ,"  newItem.html(newItem.html().replace(/fval\\[(\\d+\\.)*(\\d+)\\.(\\d+)\\]/g,"
    ,"    function(a, b, c, d) {"
    ,"      var newC = parseInt(c)+1;"
    ,"      return a.replace(/\\d+\\.\\d+\\]/, newC+'.'+d+']');"
    ,"    }"
    ,"  ));"
    ,"  newItem.appendTo(item.parent());"
    ,""
    ,"  // Copy the values of all children that had the name attribute set."
    ,"  // The direct html insertion does not preserve the most current"
    ,"  // values.  It only preserves default values, so if we want values"
    ,"  // copied, we have to use an approach like this."
    ,"  var items2 = findItems(button);"
    ,"  var newLast = $(items2[items2.length-1]);"
    ,"  var c1 = $('[name]', item);"
    ,"  var c2 = $('[name]', newLast);"
    ,"  if ( c1.length == c2.length ) {"
    ,"    for ( i = 0; i < c1.length; i++ ) {"
    ,"      $(c2[i]).val($(c1[i]).val());"
    ,"    }"
    ,"  }"
    ,"}"
    ,""
    ,"function removeItem(button) {"
    ,"  var items = findItems(button);"
    ,"  if ( items.length > 1 ) {"
    ,"    var count = $(':hidden', findInputList(button))[0];"
    ,"    var item = $(items[items.length-1]);"
    ,"    item.remove();"
    ,""
    ,"    // Decrement counter"
    ,"    $(count).val(parseInt($(count).val())-1);"
    ,"  } else {"
    ,"    alert('Cannot remove any more rows');"
    ,"  }"
    ,"}"
    ]