module Web.Horse.Forms where
import Web.Horse.Forms.Types
import Web.Horse.Forms.Basic
import Data.Monoid
import Data.List.Split (splitOn)
import Safe (readMay)
import Text.Hamlet
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Maybe
import Data.Char
import Control.Arrow.Transformer.All
import Control.Arrow.Transformer.Automaton.Monad
import Control.Arrow.Transformer.LabeledArrow
import Control.Arrow.Operations hiding (write)
import Debug.Trace
valForm
:: (ArrowReader FormIn a',
ArrowAddLabel a a',
ArrowApply a'1,
ArrowAddAutomaton a' a'1,
ArrowChoice a') =>
String
-> a' String (Either String a1)
-> String
-> a () (Html (), Maybe a1)
valForm initVal vtor label = withInput $
proc ((),nm,fi) -> do
s_curr <- keepState initVal -< fi
valid <- vtor -< s_curr
case valid of
Left err -> returnA -< (textField label (Just err) s_curr nm,
Nothing)
Right x -> returnA -< (textField label Nothing s_curr nm,
Just x)
stringForm = valForm "" (arr Right)
readForm = valForm "" (arr (\x -> maybe (Left ("No read: " ++ x)) Right (readMay x)))
enumForm label vs = withInput $
(proc ((),nm,fi) -> do
n_curr <- keepState (1) -< extractNumber fi
let n_val = max n_curr 0
res = if n_curr < 0 then Nothing else (Just $ snd $ vs !! n_curr)
returnA -< (select label (map fst vs) n_val nm, res))
where
extractNumber i = checkBounds $ readMay =<< i
checkBounds Nothing = Nothing
checkBounds (Just k) = if k >= 0 && k < length vs
then Just k else Nothing
runSubStream :: (ArrowChoice a) => a i o -> a (Maybe i) (Maybe o)
runSubStream f = proc i ->
case i of
Just i' -> f >>> (arr Just) -< i'
Nothing -> returnA -< Nothing
filterDiffs
:: (Eq i, ArrowApply a', ArrowAddAutomaton a a') => a i (Maybe i)
filterDiffs = monadToAuto $ \i1 -> do
i2 <- co (Just i1)
runFilter i1 i2
where
runFilter i1 = \i2 -> do
case i1 == i2 of
True -> runFilter i1 =<< co Nothing
False -> runFilter i2 =<< co (Just i2)
keepState :: (ArrowApply a', ArrowAddAutomaton a a') => o -> a (Maybe o) o
keepState s0 = monadToAuto (f s0)
where
f s0' ms1 = f (fromMaybe s0' ms1) =<< co (fromMaybe s0' ms1)
replaceSecond
:: (ArrowAddAutomaton a a', ArrowApply a') =>
a i o -> a (i, Maybe (a i o)) o
replaceSecond g = liftAutomaton $
(proc (i,g_new) -> do
let g_curr = elimAutomaton (fromMaybe g g_new)
(o,g') <- g_curr -<< i
returnA -< (o, replaceSecond g'))
once :: (ArrowAddAutomaton a a', ArrowApply a') => a1 -> a i (Maybe a1)
once x = monadToAuto $ \_ -> co (Just x) >> forever (co (Nothing))
auto :: Automaton a i o -> a i (o, Automaton a i o)
auto (Automaton f) = f
formSum _ [] _ = error "formSum requires at least one argument"
formSum label fs def = catchAuto $ proc _ -> do
(fo,f) <- enumForm label fs -< ()
case f of
Just f' -> throwAuto -< f'
Nothing -> returnA -< setFormOut fo def
throwAuto = proc f -> do
raise -< liftAutomaton $ LabeledArrow $
(arr (flip (,) noInput)
>>> (unLA (newReader (elimAutomaton f))))
linkForm linkName f = withInput $ proc ((),nm,iname) -> do
case iname of
Just _ -> throwAuto -< f
Nothing -> returnA -< (link linkName nm)
staticUrls :: a -> [(String, a)] -> ([String] -> a)
staticUrls def fs s =
case lookup (filter (/= "") $ map (map toLower) s)
(map ((filter (/= "") . splitOn "/") *** id) fs) of
Nothing -> def
Just f -> f