{-# LANGUAGE NoImplicitPrelude
           , TemplateHaskell
           , ViewPatterns
           , OverloadedStrings
           , QuasiQuotes
           , TemplateHaskell
           , MultiParamTypeClasses
           , TypeFamilies
           , FlexibleContexts
           , NamedFieldPuns
           , ScopedTypeVariables
           , MultiWayIf
           , RecordWildCards
#-}

module Utils.Form where

import ClassyPrelude.Yesod
import Settings

import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T
import qualified Data.Char as Char

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set

import Data.List ((!!))

import Web.PathPieces

-------------------
-- 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 "widgets/form")
  return (res, widget)

--------------------
-- Field Settings --
--------------------

fsl ::  Text -> FieldSettings site
fsl lbl =
  FieldSettings { fsLabel    = (SomeMessage lbl)
                , fsTooltip  = Nothing
                , fsId       = Nothing
                , fsName     = Nothing
                , fsAttrs    = []
  }

fslI :: RenderMessage site msg => msg -> FieldSettings site
fslI lbl =
  FieldSettings { fsLabel    = (SomeMessage lbl)
                , fsTooltip  = Nothing
                , fsId       = Nothing
                , fsName     = Nothing
                , fsAttrs    = []
  }

fslp ::  Text -> Text -> FieldSettings site
fslp lbl placeholder =
  FieldSettings { fsLabel    = (SomeMessage lbl)
                , fsTooltip  = Nothing
                , fsId       = Nothing
                , fsName     = Nothing
                , fsAttrs    = [("placeholder", placeholder)]
  }

fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
fslpI lbl placeholder =
  FieldSettings { fsLabel    = (SomeMessage lbl)
                , fsTooltip  = Nothing
                , fsId       = Nothing
                , fsName     = Nothing
                , fsAttrs    = [("placeholder", placeholder)]
  }

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 :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }

addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
addDatalist mValues field = field
  { fieldView = \fId fName fAttrs fRes fReq -> do
      listId <- newIdent
      values <- map toPathPiece . otoList <$> mValues
      fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
      [whamlet|
        $newline never
        <datalist ##{listId}>
          $forall value <- values
            <option value=#{value}>
      |]
  }

noValidate :: FieldSettings site -> FieldSettings site
noValidate = addAttr "formnovalidate" ""

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

data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece FormIdentifier where
  fromPathPiece = readFromPathPiece
  toPathPiece = showToPathPiece


identForm :: (Monad m, PathPiece ident)
          => ident -- ^ Form identification
          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
identForm = identifyForm . toPathPiece

{- Hinweise zur Erinnerung:
  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
  - nur einmal pro makeForm reicht
-}

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

data family ButtonCssClass site :: *

bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> 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 site a where
  label :: a -> WidgetT site IO ()
  label = toWidget . toPathPiece

  cssClass :: a -> ButtonCssClass site

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

instance PathPiece SubmitButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
  where
    fieldEnctype = UrlEncoded

    fieldView fid name attrs _val _ = let
      cssClass' :: ButtonCssClass site
      cssClass' = cssClass btn
      in [whamlet|
        <button .btn .#{bcc2txt cssClass'} 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 site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField btns = traverse b2f btns
  where
    b2f b = aopt (buttonField b) "" Nothing

submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
submitButton = void $ combinedButtonField [BtnSubmit]

-------------------
-- Custom Fields --
-------------------

ciField :: ( Textual t
           , CI.FoldCase t
           , Monad m
           , RenderMessage (HandlerSite m) FormMessage
           ) => Field m (CI t)
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField

reorderField :: ( MonadHandler m
                , HandlerSite m ~ site
                , Eq a
                , Show a
                ) => HandlerT site IO (OptionList a) -> Field m [a] 
-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
reorderField optList = Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldParse [] _ = return $ Right Nothing
    fieldParse optlist _ = do
      OptionList{..} <- liftHandlerT optList
      let
        olNum = fromIntegral $ length olOptions
        selOptions = Map.fromList $ do
          i <- [1..olNum]
          (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
          guard $ i == n
          Just val <- return . olReadExternal $ pack extVal
          return (i, val)
      return $ if
        | Map.keysSet selOptions == Set.fromList [1..olNum]
          -> Right . Just $ map (selOptions !) [1..fromIntegral olNum]
        | otherwise
          -> Left "Not a valid permutation"
    fieldView theId name attrs val isReq = do
      OptionList{..} <- liftHandlerT optList
      let
        isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
        nums = map (id &&& withNum theId) [1..length olOptions]
        withNum t n = tshow n <> "." <> t
      $(widgetFile "widgets/permutation")