{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Yesod.Contrib.Formable where

import Text.Formlets
import Text.Hamlet
import Data.Time (Day)
import Control.Applicative
import Control.Applicative.Error
import Web.Routes.Quasi (SinglePiece)
import Database.Persist (Persistable)
import Data.Char (isAlphaNum)
import Language.Haskell.TH.Syntax
import Database.Persist (Table (..))
import Database.Persist.Helper (upperFirst)
import Data.Convertible.Text (cs)

class Formable a where
    formable :: (Functor m, Applicative m, Monad m)
             => Formlet (Hamlet url) m a

class Fieldable a where
    fieldable :: (Functor m, Applicative m, Monad m)
              => String -> Formlet (Hamlet url) m a

instance Fieldable [Char] where
    fieldable label = input' go
      where
        go name val = [$hamlet|
%tr
    %th $string.label$
    %td
        %input!type=text!name=$string.name$!value=$string.val$
|]

instance Fieldable Html where
    fieldable label =
        fmap preEscapedString
      . input' go
      . fmap (cs . renderHtml)
      where
        go name val = [$hamlet|
%tr
    %th $string.label$
    %td
        %textarea!name=$string.name$
            $string.val$
|]

instance Fieldable Day where
    fieldable label x = input' go (fmap show x) `check` asDay
      where
        go name val = [$hamlet|
%tr
    %th $string.label$
    %td
        %input!type=date!name=$string.name$!value=$string.val$
|]
        asDay s = maybeRead' s "Invalid day"

newtype Slug = Slug { unSlug :: String }
    deriving (Read, Eq, Show, SinglePiece, Persistable)

instance Fieldable Slug where
    fieldable label x = input' go (fmap unSlug x) `check` asSlug
      where
        go name val = [$hamlet|
%tr
    %th $string.label$
    %td
        %input!type=text!name=$string.name$!value=$string.val$
|]
        asSlug [] = Failure ["Slug must be non-empty"]
        asSlug x'
            | all (\c -> c `elem` "-_" || isAlphaNum c) x' =
                Success $ Slug x'
            | otherwise = Failure ["Slug must be alphanumeric, - and _"]

share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
share2 f g a = do
    f' <- f a
    g' <- g a
    return $ f' ++ g'

deriveFormable :: [Table] -> Q [Dec]
deriveFormable = mapM derive
  where
    derive :: Table -> Q Dec
    derive t = do
        let cols = map (upperFirst . fst) $ tableColumns t
        ap <- [|(<*>)|]
        just <- [|pure|]
        nothing <- [|Nothing|]
        let just' = just `AppE` ConE (mkName $ tableName t)
        let c1 = Clause [ConP (mkName "Nothing") []]
                        (NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
                        []
        xs <- mapM (const $ newName "x") cols
        let xs' = map (AppE just . VarE) xs
        let c2 = Clause [ConP (mkName "Just") [ConP (mkName $ tableName t)
                            $ map VarP xs]]
                        (NormalB $ go ap just' $ zip cols xs')
                        []
        return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t))
            [FunD (mkName "formable") [c1, c2]]
    go ap just' = foldl (ap' ap) just' . map go'
    go' (label, ex) = VarE (mkName "fieldable") `AppE` LitE (StringL label) `AppE` ex
    ap' ap x y = InfixE (Just x) ap (Just y)