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

module Handler.Utils.Form where 

import Import
-- import Data.Time
import Data.Proxy
import qualified Data.Map as Map
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 

import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Text.Blaze (Markup)
----------------------------
-- Buttons (new version ) --
----------------------------

class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
  label :: a -> Widget
  label = toWidget . toPathPiece
  
buttonForm :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
buttonForm html = do
  let 
    buttonValues = [minBound..maxBound] 
    buttonMap  = Map.fromList $ zip buttonValues buttonValues
    button b = Field parse view UrlEncoded
      where
        parse []    _ = return $ Right Nothing
        parse [str] _ 
          | str == toPathPiece b = return $ Right $ Just b
          | otherwise = return $ Left "Wrong button value"
        parse _ _ = return $ Left "Multiple button values"
        
        view id name attrs _val _ = do
          [whamlet|
            #{html}
            <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece b} *{attrs} ##{id}>^{label b}
          |]
  
  buttonIdent <- newFormIdent
  resultWidgetMap <- forM buttonMap $ \val -> mopt (button val) ("" { fsName = Just buttonIdent }) Nothing
    
  let result = accResult $ fst <$> Map.elems resultWidgetMap
  let viewF = (Map.!) (snd <$> resultWidgetMap)
  
  return (result, viewF)
  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 _) (FormSuccess _) = FormFailure ["Ambiguous parse"]
    accResult' (FormSuccess (Just x)) _ = FormSuccess x
    accResult' _ x = x
  
----------------------------
-- Buttons (old version ) --
----------------------------

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 :: MonadHandler m => 
--     Text -> Text.Blaze.Internal.Markup -> MForm m (FormResult (), WidgetT (HandlerSite m) IO ())
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)