{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-}
{-# OPTIONS_GHC -F -pgmF trhsx #-}
module HSPForm where

import Control.Applicative
import Control.Applicative.Compose
import Control.Applicative.Error
import Control.Applicative.State
import Control.Concurrent
import HSP
import HSP.HTML
import HAppS.Template.HSP
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import HAppS.Server hiding (Web)
import HAppS.Template.HSP.Handle
import Text.RJson
import System.Environment
import qualified Data.Map as Map
import HAppS.Server.Extra



import HSX.XMLGenerator hiding (XMLGen(..))
import qualified HSX.XMLGenerator as HSX (XMLGen(..))

type Env = [(String, String)]
type FormState = Names
type Names = Integer
type Name = String
type Collector a = Env -> a


element :: (IsName n) => n -> Attributes -> Children -> XML
element n attributes children = Element (toName n) attributes children

attr :: (IsName n) => n -> String -> Attribute
attr n v = MkAttr (toName n, pAttrVal v)

attrs :: (IsName n) => [(n, String)] -> Attributes
attrs = map (uncurry attr)

newtype Form a = Form { deform :: Env -> State FormState (Collector a, [XML]) }

instance Applicative (Reader a) where
    pure = return
    (<*>) = ap


instance Functor Form where
  fmap f (Form a) = Form $ \env -> (fmap . fmapFst . fmap) f (a env)
   where fmapFst f (a, b) = (f a, b)

instance Applicative Form where
   pure = pureF
   (<*>) = applyF

pureF :: a -> Form a
pureF v = Form $ \env -> pure (const v, []) -- K

applyF :: Form (a -> b) -> Form a -> Form b
(Form f) `applyF` (Form v) = Form $ \env -> pure combine <*> f env <*> v env
   where combine (f, x) (v, y) = (\e -> f e (v e), x ++ y)

instance Applicative HSP where
    pure = return
    (<*>) = ap

freshName :: State FormState String
freshName = do n <- get
               put $ n + 1
               return $ "input" ++ show n

currentName :: State FormState String
currentName = gets $ (++) "input" . show


{- component: just some xml -}
xml :: XML -> Form ()
xml x = Form $ \env -> pure (const (), [x])

{- component: just some text -}
text :: String -> Form ()
text s = Form $ \env -> pure (const (), [pcdata s])

{- transform the XML component -}
plug :: ([XML] -> [XML]) -> Form a -> Form a
f `plug` (Form m) = Form $ \env -> pure plugin <*> m env
   where plugin :: (a, [XML]) -> (a, [XML])
         plugin (c, x) = (c, f x)

-- | A form whose output may fail
type FailingForm a = (Form :+: Failing) a

runFormState :: Env             -- ^ A previously filled environment (may be empty)
             -> FailingForm a   -- ^ The form
             -> FormState       -- ^ Initial form state
             -> ((Collector (Failing a), [XML]), FormState)
runFormState e f s = (runState (deform (decompose f) e) s)


createForm :: Env -> FailingForm a -> [XML]
createForm env frm =
    let ((_extractor, xml), _endState) = runFormState env frm 0
    in xml

-- | Lifts a function on a Form to a function on a composed form.
liftForm :: (Form (f a) -> Form (f a)) -> (Form :+: f) a -> (Form :+: f) a
liftForm f = Compose . f . decompose

-- | Lift a form component to a failing form component
validate :: Form a -> FailingForm a
validate f = Compose $ pure Success <*> f

-- | Add additional validation to an already validated component
check :: FailingForm a -> (a -> Failing b) -> FailingForm b
check form f = decompose form `chk` checker f
   where chk :: Form a -> (a -> Failing b) -> FailingForm b
         chk form validator = Compose $ pure validator <*> form
         checker :: (a -> Failing b) -> (Failing a -> Failing b)
         checker f (Failure x) = Failure x
         checker f (Success x) = f x

-- | Apply a predicate to a value and return Success or Failure as appropriate
ensure :: Show a 
       => (a -> Bool) -- ^ The predicate
       -> String      -- ^ The error message, in case the predicate fails
       -> a           -- ^ The value
       -> Failing a
ensure p msg x | p x = Success x
               | otherwise = Failure [msg]


-- | Helper function for genereting input components based.
input' :: (String -> String -> [XML]) -> Maybe String -> Form String
input' i defaultValue = Form $ \env -> mkInput env <$> freshName
   where mkInput :: Env -> String -> (Collector String, [XML])
         mkInput env name = (flip queryParam name, i name (value name env))
         value name env = maybe (maybe "" id defaultValue) id (lookup name env)

queryParam :: Env -> HSPForm.Name -> String
queryParam env name = case (name `lookup` env) of
                           Nothing -> error $ "Couldn't find " ++ name
                           Just x  -> x

-- | Component: an input field with an optional value
-- input :: Maybe String -> Form String
-- input = input' (\n v -> X.textfield n ! [X.value v])

input :: Maybe String -> Form String
input = input' (\n v -> [element "input" (attrs [("type","text"),("name", n), ("id", n), ("value",v)]) []])

-- | Component: a password field with an optional value
password :: Maybe String -> Form String
password = input' (\n v -> [element "input" (attrs [("type","password"),("name", n), ("id", n), ("value",v)]) []])

-- | A trivially validated input component
inputF :: Maybe String -> FailingForm String
inputF = validate . input

-- | A trivially validated password component
passwordF :: Maybe String -> FailingForm String
passwordF = validate . password

-- | A validated integer component
inputIntegerF :: Maybe Integer -> FailingForm Integer
inputIntegerF x = validate (input $ fmap show x) `check` asInteger

instance EmbedAsChild (HSPT' (WriterT (Endo XML) (ReaderT WebState IO))) (FailingForm a) where
    asChild c = 
        do env <- localRead "env"
           asChild (createForm env c) 

withForm :: String
         -> FailingForm a
         -> (Env -> [ErrorMsg] -> WebT (StateT HSPState IO) Response)
         -> (a -> WebT (StateT HSPState IO) Response)
         -> [ServerPartT (StateT HSPState IO) Response]
withForm name frm handleErrors handleOk =
   [ dir name
      [ method GET $ do addParam "env" ([] :: Env)
                        addParam "errors" (Nothing :: Maybe [ErrorMsg])
                        ok =<< execTemplate Nothing "FormPage.hs"
      , withDataFn lookPairs $ \d -> [method POST $ handleOk' d]
      ]
   ]
   where ((extractor, html), endState) = runFormState [] frm 0
         handleOk' d = case extractor d of
                         Failure faults -> handleErrors d faults
                         Success s      -> handleOk s

-- * 

testForm :: Web XML
testForm =
    <form method="POST">
              <% inputF (Just "1") `check` asInteger %>
    </form>


test :: IO ()
test =
    do (xmd, xml) <- evalHSP (runWebXML (WebState { queryGlobal = undefined, queryLocal = Map.fromList [("env", toJson [("input_0", "bork brok brok")])] }) testForm) Nothing
       putStrLn (renderAsHTML xml)


-- check that this instance is valid (ie, follows the laws)
instance Monad Form where
    return = pure
    (Form f) >>= g = Form $ \env -> 
                     do (c1,xml1) <- f env
                        let (Form g') = g (c1 env)
                        (c2,xml2) <- g' env
                        return (c2, xml1 ++ xml2)