{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Yesod.Formable
    ( Form (..)
    , Formlet
    , FormResult (..)
    , runForm
    , runIncr
    , Formable (..)
    , deriveFormable
    , share2
    , wrapperRow
    , sealFormlet
    ) where

import Text.Hamlet
import Data.Time (Day)
import Control.Applicative
import Database.Persist (Persistable)
import Data.Char (isAlphaNum)
import Language.Haskell.TH.Syntax
import Database.Persist (Table (..))
import Database.Persist.Helper (upperFirst)
import Control.Monad (liftM)
import Control.Arrow (first)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty, mappend)
import qualified Data.ByteString.Lazy.UTF8
import Yesod.Request
import Yesod.Handler
import Control.Monad.IO.Class (liftIO)
import Web.Routes.Quasi

runForm :: Form (Routes y) a
        -> GHandler sub y (FormResult a, Hamlet (Routes y))
runForm f = do
    req <- getRequest
    (pp, _) <- liftIO $ reqRequestBody req
    return $ fst $ runIncr (deform f pp) 1

type Env = [(String, String)]

newtype Incr a = Incr { runIncr :: Int -> (a, Int) }
incr :: Incr Int
incr = Incr $ \i -> (i + 1, i + 1)
instance Monad Incr where
    return a = Incr $ \i -> (a, i)
    Incr x >>= f = Incr $ \i ->
        let (x', i') = x i
         in runIncr (f x') i'

data FormResult a = FormMissing
                  | FormFailure [String]
                  | FormSuccess a
instance Functor FormResult where
    fmap _ FormMissing = FormMissing
    fmap _ (FormFailure errs) = FormFailure errs
    fmap f (FormSuccess a) = FormSuccess $ f a
instance Applicative FormResult where
    pure = FormSuccess
    (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
    (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
    (FormFailure x) <*> _ = FormFailure x
    _ <*> (FormFailure y) = FormFailure y
    _ <*> _ = FormMissing

newtype Form url a = Form
    { deform :: Env -> Incr (FormResult a, Hamlet url)
    }
type Formlet url a = Maybe a -> Form url a

instance Functor (Form url) where
    fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)

instance Applicative (Form url) where
    pure a = Form $ const $ return (pure a, mempty)
    (Form f) <*> (Form g) = Form $ \env -> do
        (f1, f2) <- f env
        (g1, g2) <- g env
        return (f1 <*> g1, f2 `mappend` g2)

sealForm :: ([String] -> Hamlet url -> Hamlet url)
         -> Form url a -> Form url a
sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)
  where
    go (res, xml) = (res, wrapper (toList res) xml)
    toList (FormFailure errs) = errs
    toList _ = []

sealFormlet :: ([String] -> Hamlet url -> Hamlet url)
            -> Formlet url a -> Formlet url a
sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal

input' :: (String -> String -> Hamlet url)
       -> Maybe String
       -> Form url String
input' mkXml val = Form $ \env -> do
    i <- incr
    let i' = show i
    let param = lookup i' env
    let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param
    return (maybe FormMissing FormSuccess param, xml)

check :: Form url a -> (a -> Either [String] b) -> Form url b
check (Form form) f = Form $ \env -> liftM (first go) (form env)
  where
    go FormMissing = FormMissing
    go (FormFailure x) = FormFailure x
    go (FormSuccess a) =
        case f a of
            Left errs -> FormFailure errs
            Right b -> FormSuccess b

class Formable a where
    formable :: Formlet url a

wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
wrapperRow label errs control = [$hamlet|
%tr
    %th $string.label$
    %td ^control^
    $if not.null.errs
        %td.errors
            %ul
                $forall errs err
                    %li $string.err$
|]

instance Formable [Char] where
    formable = input' go
      where
        go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$
|]

instance Formable Html where
    formable = fmap preEscapedString
              . input' go
              . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
      where
        go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]

instance Formable Day where
    formable x = input' go (fmap show x) `check` asDay
      where
        go name val = [$hamlet|
%input!type=date!name=$string.name$!value=$string.val$
|]
        asDay s = case reads s of
                    (y, _):_ -> Right y
                    [] -> Left ["Invalid day"]

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

instance Formable Slug where
    formable x = input' go (fmap unSlug x) `check` asSlug
      where
        go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$
|]
        asSlug [] = Left ["Slug must be non-empty"]
        asSlug x'
            | all (\c -> c `elem` "-_" || isAlphaNum c) x' =
                Right $ Slug x'
            | otherwise = Left ["Slug must be alphanumeric, - and _"]

newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String }
    deriving (Read, Eq, Show, SinglePiece, Persistable)
instance Formable NonEmptyString where
    formable x = input' go (fmap unNonEmptyString x) `check` notEmpty
      where
        go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$
|]
        notEmpty "" = Left ["Must be non-empty"]
        notEmpty y = Right $ NonEmptyString y

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 "sealForm") `AppE`
        (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
        (VarE (mkName "formable") `AppE` ex)
    ap' ap x y = InfixE (Just x) ap (Just y)