{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}

module Handler.Utils.Form where 

import Import
import qualified Data.Char as Char
import Handler.Utils.DateTime
import Data.String (IsString(..))

import qualified Data.Foldable as Foldable

-- import Yesod.Core
import qualified Data.Text as T
-- import Yesod.Form.Types
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3 


----------------------------
-- Buttons (new version ) --
----------------------------

data ButtonCssClass = Default | Primary | Success | Info | Warning | Danger | Link
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

bcc2txt :: ButtonCssClass -> Text
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> show bcc)

class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
  label :: a -> Widget
  label = toWidget . toPathPiece

  cssClass :: a -> ButtonCssClass
  cssClass _ = Default
  

buttonField :: Button a => a -> Field Handler a
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
  where 
    fieldEnctype = UrlEncoded
    
    fieldView fid name attrs _val _ = 
      [whamlet|
        <button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
      |]
      
    fieldParse []    _ = return $ Right Nothing
    fieldParse [str] _ 
      | str == toPathPiece btn = return $ Right $ Just btn
      | otherwise  = return $ Left "Wrong button value"
    fieldParse _ _ = return $ Left "Multiple button values"
    

-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
buttonForm :: (Button a) => Form a
buttonForm csrf = do
    buttonIdent <- newFormIdent
    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing  
    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
    let widget = do
          [whamlet|
            #{csrf}
            $forall bView <- btnViews
              ^{fvInput bView}
          |]
    return (accResult results,widget)
  where
    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
    accResult = Foldable.foldr accResult' FormMissing

    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
    accResult' (FormSuccess (Just x)) _ = FormSuccess x
    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
    accResult' (FormSuccess Nothing) x = x
    accResult' FormMissing _ = FormMissing
    accResult' (FormFailure errs) _ = FormFailure errs

  
---------------------------------------
-- Buttons (old version, deprecated) --
---------------------------------------

formBtnSave  :: (Text,Text,Text)
formBtnSave   = ("save"  ,"Speichern"  ,"btn-primary")

formBtnAbort :: (Text,Text,Text)
formBtnAbort  = ("abort" ,"Abbrechen"  ,"btn-default")

formBtnDelete ::(Text,Text,Text)
formBtnDelete = ("delete","Löschen"    ,"btn-warning")

formActionSave :: Maybe Text
formActionSave   = Just $ fst3 formBtnSave

formActionAbort :: Maybe Text
formActionAbort  = Just $ fst3 formBtnAbort

formActionDelete :: Maybe Text
formActionDelete = Just $ fst3 formBtnDelete

defaultFormActions :: [(Text,Text,Text)]
defaultFormActions =  [ formBtnDelete
                      , formBtnAbort
                      , formBtnSave
                      ]

-- Post-Buttons
postButtonForm :: Text -> Form ()
postButtonForm lblId = identifyForm lblId buttonF
  where
    buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps
    bProps :: BootstrapSubmit Text
    bProps = fromString $ unpack lblId
    
    
------------
-- Fields --
------------

natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") $ intField

posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") $ intField

minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField


schoolField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m SchoolId
schoolField = undefined -- TODO

utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
utcTimeField = Field 
    { fieldParse = parseHelper $ readTime
    , fieldView = \theId name attrs val isReq ->
        [whamlet|
          $newline never
          <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id showTime val}">
        |]
    , fieldEnctype = UrlEncoded
    }
  where 
    fieldTimeFormat :: String
    fieldTimeFormat = "%e.%m.%y %k:%M"
    
    readTime :: Text -> Either FormMessage UTCTime
    readTime t = 
      case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
        (Just time) -> Right time
        Nothing -> Left $ MsgInvalidEntry "Datum/Zeit Format: tt.mm.yy hh:mm"
        
    showTime :: UTCTime -> Text 
    showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)