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

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 

import qualified Text.Blaze.Internal as Blaze (null)

import Web.PathPieces (showToPathPiece, readFromPathPiece)

------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------

data FormIdentifier = FIDcourse | FIDsheet
  deriving (Enum, Eq, Ord, Bounded, Read, Show)


identForm :: FormIdentifier -> Form a -> Form a  
identForm fid = identifyForm (T.pack $ show fid)

-------------------
-- Form Renderer --
-------------------

-- | Use this type to pass information to the form template
data FormLayout = FormStandard

renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
  (res, (($ []) -> views)) <- aFormToForm aform
  let widget = $(widgetFile "form")
  return (res, widget)

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

data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))

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

  cssClass :: a -> ButtonCssClass
  cssClass _ = BCDefault
  


{- Abort is not useful (press Back instead); Delete should be different:
data StandardButton = BtnDelete | BtnAbort | BtnSave
  deriving (Enum, Eq, Ord, Bounded, Read, Show)
     
instance PathPiece StandardButton where    -- for displaying the button only, not really for paths
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

instance Button StandardButton where
  label BtnDelete = "Löschen"
  label BtnAbort  = "Abbrechen"
  label BtnSave   = "Speichern"
  
  cssClass BtnDelete = BCWarning
  cssClass BtnAbort  = BCDefault
  cssClass BtnSave   = BCPrimary
-}

data SubmitButton = BtnSubmit
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece SubmitButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

instance Button SubmitButton where
  label BtnSubmit = "Submit"

  cssClass BtnSubmit = BCPrimary
  
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)  
-- data LinkButton = LinkButton (Route UniWorX)
--   deriving (Enum, Eq, Ord, Bounded, Read, Show)
-- 
-- instance PathPiece LinkButton where
--     LinkButton route = ???
  
linkButton :: Widget -> ButtonCssClass -> Route UniWorX -> Widget
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
--   [whamlet|
--     <form method=post action=@{url}>      
--       <input type="hidden" name="_formid" value="identify-linkButton">
--       <button .btn .#{bcc2txt cls} type=submit value="Link to @{url}">^{lbl}
--   |] 
  --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}> 
  
  
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"
    
    
combinedButtonField :: Button a => [a] -> AForm Handler [Maybe a]
combinedButtonField btns = traverse b2f btns
  where
    b2f b = aopt (buttonField b) "" Nothing 

submitButton :: AForm Handler ()
submitButton = void $ combinedButtonField [BtnSubmit]

    {-
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
combinedButtonField btns inner csrf = do
    buttonIdent <- newFormIdent
    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing  
    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
    (innerRes,innerWdgt) <- inner
    let widget = do 
          [whamlet|
            #{csrf}
            ^{innerWdgt}
            <div .btn-group>
              $forall bView <- btnViews
                ^{fvInput bView}
          |]
    let result = case (accResult result, innerRes) of
                    (FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
                    _ -> FormFailure ["Something went wrong"] -- TODO
    return (result,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       
    -}

-- 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 = renderAForm FormStandard $ 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


--termField: see Utils.Term

schoolField :: Field Handler SchoolId
schoolField = selectField schools
  where
    schools = optionsPersistKey [] [Asc SchoolName] schoolName

schoolEntField :: Field Handler (Entity School)
schoolEntField = selectField schools
  where
    schools = optionsPersist [] [Asc SchoolName] schoolName

sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq d Nothing =
  -- TODO, offer options to choose between Normal/Bonus/Pass
  (Normal . toPoints) <$> areq (natField "Punkte") d Nothing
sheetTypeAFormReq d (Just (Normal p)) =
  -- TODO, offer options to choose between Normal/Bonus/Pass
  (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)

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="datetime-local" :isReq:required value="#{either id showTime val}">
        |]
    , fieldEnctype = UrlEncoded
    }
  where 
    fieldTimeFormat :: String
    --fieldTimeFormat = "%e.%m.%y %k:%M"
    fieldTimeFormat = "%Y-%m-%eT%H:%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 " ++ t
        
    showTime :: UTCTime -> Text 
    showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)

    
fsb :: Text -> FieldSettings site 
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors     
   
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
  where 
    newAttrs :: [(Text,Text)] -> [(Text,Text)]
    newAttrs [] = [(attr,valu)]
    newAttrs (p@(a,v):t) 
      | attr==a   = (a,T.append valu $ cons ' ' v):t
      | otherwise = p:(newAttrs t)   

addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
  where 
    newAttrs :: [(Text,Text)] -> [(Text,Text)]
    newAttrs [] = [(attr,T.intercalate " " valus)]
    newAttrs (p@(a,v):t) 
      | attr==a   = (a,T.intercalate " " (v:valus)):t
      | otherwise = p:(newAttrs t)   
            
addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class"

addClasses :: [Text] -> FieldSettings site -> FieldSettings site
addClasses = addAttrs "class"

addName :: Text -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just nm }

addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }

addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }


setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated 
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }

setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }

setTooltip :: String -> FieldSettings site -> FieldSettings site
setTooltip tt fs
  | null tt   = fs { fsTooltip = Nothing }
  | otherwise = fs { fsTooltip = Just $ fromString tt }