diff --git a/Control/Arrow/Transformer/Automaton/Maybe.hs b/Control/Arrow/Transformer/Automaton/Maybe.hs new file mode 100644 --- /dev/null +++ b/Control/Arrow/Transformer/Automaton/Maybe.hs @@ -0,0 +1,69 @@ +module Control.Arrow.Transformer.Automaton.Maybe where + +import Control.Arrow +import qualified Control.Category as C +import Control.Arrow.Operations +import qualified Control.Arrow.Transformer as AT +import Control.Arrow.Transformer.All + +import Data.Maybe +import qualified Data.Map as M + +--A MaybeAutomaton returns either Just f to indicate a new Automaton, +--or Nothing to indicate 'no change'/'do the same thing'. +newtype MaybeAutomaton a i o = + MaybeAutomaton (a i (o, Maybe (Automaton a i o))) + +mAut (MaybeAutomaton f) = f + +automatonFromMaybe f = + Automaton (mAut f >>> second (arr (fromMaybe (automatonFromMaybe f)))) + +maybeFromAutomaton (Automaton f) = + MaybeAutomaton (f >>> second (arr Just)) + + +--Why use MaybeAutomata? The arrow instances coalesce Nothings, +--reducing memory use. + +instance (Arrow a) => C.Category (MaybeAutomaton a) where + (.) f g = + MaybeAutomaton $ (mAut g) >>> (mAut f *** arr id) >>> + arr (\((o,f'),g') -> (o, + case (f',g') of + (Nothing,Nothing) -> Nothing + (_,_) -> Just $ + fromMaybe (automatonFromMaybe f) f' + C.. + fromMaybe (automatonFromMaybe g) g')) + + id = MaybeAutomaton (C.id >>> arr (flip (,) Nothing)) + +instance (Arrow a) => Arrow (MaybeAutomaton a) where + arr f = MaybeAutomaton (arr f >>> arr (flip (,) Nothing)) + + + (***) f g = MaybeAutomaton $ (mAut f *** mAut g) >>> + arr (\((o1,f'),(o2,g')) -> + ((o1,o2), + case (f',g') of + (Nothing,Nothing) -> Nothing + (_,_) -> Just $ + fromMaybe (automatonFromMaybe f) f' + *** + fromMaybe (automatonFromMaybe g) g')) + + first f = f *** arr id + second f = arr id *** f + + +instance (ArrowChoice a) => ArrowChoice (MaybeAutomaton a) where + (+++) f g = MaybeAutomaton $ mAut f +++ mAut g >>> + arr (\x -> case x of + Left (o,f') -> (Left o, + fmap (+++ automatonFromMaybe g) f') + Right (o,g') -> (Right o, + fmap (automatonFromMaybe f +++) g')) + + left f = f +++ arr id + right f = arr id +++ f diff --git a/Control/Arrow/Transformer/Automaton/Monad.hs b/Control/Arrow/Transformer/Automaton/Monad.hs --- a/Control/Arrow/Transformer/Automaton/Monad.hs +++ b/Control/Arrow/Transformer/Automaton/Monad.hs @@ -2,7 +2,7 @@ UndecidableInstances, FunctionalDependencies, NoMonomorphismRestriction #-} module Control.Arrow.Transformer.Automaton.Monad - (monadToAuto, co, autoToMonad, readerArrow, swapsnd, + (readerArrow, swapsnd, autoToMonad, co, monadToAuto, pushError,popError,rstrength, ArrowAddAutomaton (..), dispatch) where @@ -14,6 +14,7 @@ import Control.Arrow.Operations import qualified Control.Arrow.Transformer as AT import Control.Arrow.Transformer.All +import Control.Arrow.Transformer.Automaton.Maybe import Data.Maybe import qualified Data.Map as M @@ -21,20 +22,20 @@ unAM (ArrowMonad f) = f monadToAuto - :: (ArrowAddAutomaton a a', ArrowApply a') => + :: (ArrowAddAutomaton a may a', ArrowApply a') => (i -> ContT (o, a i o) (ArrowMonad a') z) -> a i o monadToAuto f = liftAutomaton (proc i -> unAM ((f i) `runContT` (error "automaton ended")) -<< ()) co - :: (ArrowApply a', ArrowAddAutomaton a a') => + :: (ArrowApply a', ArrowAddAutomaton a may a') => o -> ContT (o, a i o) (ArrowMonad a') i co o = ContT (\fi -> return (o, liftAutomaton (proc i -> unAM (fi i) -<< ()))) autoToMonad - :: (ArrowApply a', ArrowAddAutomaton a a') => + :: (ArrowApply a', ArrowAddAutomaton a may a') => a i (Either o z) -> i -> ContT (o, a i o) (ArrowMonad a') z @@ -46,64 +47,104 @@ -class ArrowAddAutomaton a a' | a -> a' where +class (ArrowChoice a, ArrowChoice may, ArrowChoice a', ArrowApply a') + => ArrowAddAutomaton a may a' | a -> a', a -> may, may -> a where elimAutomaton :: a i o -> a' i (o, a i o) liftAutomaton :: a' i (o, a i o) -> a i o constantAutomaton :: a' i o -> a i o -instance (Arrow a) => ArrowAddAutomaton (Automaton a) a where + toMaybeAutomaton :: a i o -> may i o + fromMaybeAutomaton :: may i o -> a i o + liftMaybeAutomaton :: a' i (o, Maybe (a i o)) -> may i o + elimMaybeAutomaton :: may i o -> a' i (o, Maybe (a i o)) + +instance (ArrowChoice a, ArrowApply a) => + ArrowAddAutomaton (Automaton a) (MaybeAutomaton a) a where + elimAutomaton (Automaton f) = f liftAutomaton = Automaton constantAutomaton f = Automaton (f >>> arr (flip (,) (constantAutomaton f))) -instance (Arrow a, Arrow a', ArrowAddAutomaton a a') - => ArrowAddAutomaton (StateArrow s a) (StateArrow s a') where + toMaybeAutomaton = maybeFromAutomaton + fromMaybeAutomaton = automatonFromMaybe + liftMaybeAutomaton = MaybeAutomaton + elimMaybeAutomaton = mAut + +instance (Arrow a, Arrow may, Arrow a', ArrowAddAutomaton a may a') + => ArrowAddAutomaton (StateArrow s a) (StateArrow s may) (StateArrow s a') where elimAutomaton = autoState . elimAutomaton . runState liftAutomaton = stateArrow . liftAutomaton . stateAuto constantAutomaton = stateArrow . constantAutomaton . runState + + toMaybeAutomaton = stateArrow . toMaybeAutomaton . runState + fromMaybeAutomaton = stateArrow . fromMaybeAutomaton . runState + liftMaybeAutomaton = error "not implemented yet" + elimMaybeAutomaton = error "not implemented yet" instance (ArrowState s a, ArrowApply a) => (MonadState s (ArrowMonad a)) where put s = ArrowMonad (proc () -> store -< s) get = ArrowMonad fetch -instance (Arrow a, Arrow a', ArrowAddAutomaton a a') - => ArrowAddAutomaton (ReaderArrow r a) (ReaderArrow r a') where +instance (Arrow a, Arrow a', ArrowAddAutomaton a may a') + => ArrowAddAutomaton (ReaderArrow r a) (ReaderArrow r may) (ReaderArrow r a') where elimAutomaton = (>>> (second (arr readerArrow))) . readerArrow . elimAutomaton . runReader + elimMaybeAutomaton = (>>> (second (arr (fmap readerArrow)))) . + readerArrow . elimMaybeAutomaton . runReader + liftAutomaton = readerArrow . liftAutomaton . (>>> (second (arr runReader))) . runReader + + liftMaybeAutomaton = readerArrow . liftMaybeAutomaton . + (>>> (second (arr (fmap runReader)))) . runReader + constantAutomaton = readerArrow . constantAutomaton . runReader + toMaybeAutomaton = readerArrow . toMaybeAutomaton . runReader + fromMaybeAutomaton = readerArrow . fromMaybeAutomaton . runReader -instance (ArrowChoice a, ArrowChoice a', ArrowAddAutomaton a a') - => ArrowAddAutomaton (ErrorArrow ex a) (ErrorArrow ex a') where +instance (ArrowChoice a, ArrowChoice may, ArrowChoice a', ArrowAddAutomaton a may a') + => ArrowAddAutomaton (ErrorArrow ex a) (ErrorArrow ex may) (ErrorArrow ex a') where elimAutomaton = pushError . (>>> second (arr pushError) >>> arr rstrength) . elimAutomaton . popError + elimMaybeAutomaton = pushError . + (>>> second (arr (fmap pushError)) >>> arr rstrength) + . elimMaybeAutomaton . popError + liftAutomaton f = pushError $ liftAutomaton $ (>>> arr (revrstrength (liftAutomaton f)) >>> second (arr popError)) $ popError f + liftMaybeAutomaton f = + pushError $ liftMaybeAutomaton $ + (>>> arr (revrstrength (Just $ fromMaybeAutomaton $ liftMaybeAutomaton f)) + >>> second (arr (fmap popError))) + $ popError f + constantAutomaton = pushError . constantAutomaton . popError + toMaybeAutomaton = pushError . toMaybeAutomaton . popError + fromMaybeAutomaton = pushError . fromMaybeAutomaton . popError dispatch = dispatch0 M.empty dispatch0 - :: (Ord k, - ArrowAddAutomaton a a', - ArrowApply a') => - M.Map k (a i o) -> (k -> a i o) -> a (i, k) o -dispatch0 mp def = liftAutomaton $ proc (i,k) -> do + :: (ArrowAddAutomaton a may a', + Ord k) => + M.Map k (may i o) -> (k -> may i o) -> may (i, k) o +dispatch0 mp def = liftMaybeAutomaton $ proc (i,k) -> do let f = fromMaybe (def k) (M.lookup k mp) - (o,f') <- app -< (elimAutomaton f,i) - returnA -< (o, dispatch0 (M.insert k f' mp) def) + (o,f') <- app -< (elimMaybeAutomaton f,i) + case f' of + Nothing -> returnA -< (o, Nothing) + Just f' -> returnA -< (o, Just $ fromMaybeAutomaton $ dispatch0 (M.insert k (toMaybeAutomaton f') mp) def) --Utility functions diff --git a/Control/Arrow/Transformer/LabeledArrow.hs b/Control/Arrow/Transformer/LabeledArrow.hs --- a/Control/Arrow/Transformer/LabeledArrow.hs +++ b/Control/Arrow/Transformer/LabeledArrow.hs @@ -87,15 +87,24 @@ LabeledArrow $ (pushId 0 f *** pushId 1 g) first f = f *** (arr id) -instance (Arrow a, Arrow a', ArrowAddAutomaton a a') => - ArrowAddAutomaton (LabeledArrow a) (LabeledArrow a') where +instance (Arrow a, Arrow a', ArrowAddAutomaton a may a') => + ArrowAddAutomaton (LabeledArrow a) (LabeledArrow may) (LabeledArrow a') where liftAutomaton (LabeledArrow f) = LabeledArrow $ liftAutomaton (f >>> second (arr unLA)) + liftMaybeAutomaton (LabeledArrow f) = + LabeledArrow $ liftMaybeAutomaton (f >>> second (arr (fmap unLA))) + elimAutomaton (LabeledArrow f) = LabeledArrow $ elimAutomaton f >>> second (arr LabeledArrow) + elimMaybeAutomaton (LabeledArrow f) = + LabeledArrow $ elimMaybeAutomaton f + >>> second (arr (fmap LabeledArrow)) + constantAutomaton = LabeledArrow . constantAutomaton . unLA + toMaybeAutomaton = LabeledArrow . toMaybeAutomaton . unLA + fromMaybeAutomaton = LabeledArrow . fromMaybeAutomaton . unLA instance (ArrowError ex a) => (ArrowError ex (LabeledArrow a)) where raise = LabeledArrow raise diff --git a/Web/Horse/Forms.hs b/Web/Horse/Forms.hs --- a/Web/Horse/Forms.hs +++ b/Web/Horse/Forms.hs @@ -21,16 +21,6 @@ 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 @@ -45,6 +35,11 @@ readForm = valForm "" (arr (\x -> maybe (Left ("No read: " ++ x)) Right (readMay x))) +enumForm + :: (ArrowAddAutomaton a1 may a', + ArrowAddLabel a may, + ArrowReader FormIn may) => + String -> [(String, b)] -> a () (Html (), Maybe b) enumForm label vs = withInput $ (proc ((),nm,fi) -> do n_curr <- keepState (-1) -< extractNumber fi @@ -65,7 +60,10 @@ Nothing -> returnA -< Nothing filterDiffs - :: (Eq i, ArrowApply a', ArrowAddAutomaton a a') => a i (Maybe i) + :: (ArrowAddAutomaton a may a', + Eq i, + ArrowApply a') => + a i (Maybe i) filterDiffs = monadToAuto $ \i1 -> do i2 <- co (Just i1) runFilter i1 i2 @@ -75,25 +73,30 @@ 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 @@ -101,13 +104,22 @@ formSum _ [] _ = error "formSum requires at least one argument" -formSum label fs def = catchAuto $ proc _ -> do +formSum label fs def = catchMayAuto $ proc _ -> do (fo,f) <- enumForm label fs -< () case f of - Just f' -> throwAuto -< f' + Just f' -> throwMayAuto -< f' Nothing -> returnA -< setFormOut fo def +{- +throwMayAuto = proc f -> do + raise -< liftMaybeAutomaton $ LabeledArrow $ + (arr (flip (,) noInput) + >>> (unLA (newReader (elimMaybeAutomaton f)))) +-} + +throwMayAuto = arr (fromMaybeAutomaton) >>> throwAuto + throwAuto = proc f -> do raise -< liftAutomaton $ LabeledArrow $ (arr (flip (,) noInput) @@ -115,7 +127,7 @@ linkForm linkName f = withInput $ proc ((),nm,iname) -> do case iname of - Just _ -> throwAuto -< f + Just _ -> throwMayAuto -< f Nothing -> returnA -< (link linkName nm) diff --git a/Web/Horse/Forms/Types.hs b/Web/Horse/Forms/Types.hs --- a/Web/Horse/Forms/Types.hs +++ b/Web/Horse/Forms/Types.hs @@ -1,9 +1,10 @@ {-#LANGUAGE Arrows, TypeSynonymInstances, FlexibleInstances, - FlexibleContexts #-} + FlexibleContexts, NoMonomorphismRestriction #-} module Web.Horse.Forms.Types where import Control.Arrow.Transformer.Automaton.Monad +import Control.Arrow.Transformer.Automaton.Maybe import Control.Arrow.Transformer.LabeledArrow import Text.Hamlet import Debug.Trace @@ -16,14 +17,18 @@ newtype FormIn = FormIn [(String,String)] deriving (Show) type HoH i o = LabeledArrow (ReaderArrow FormIn (Automaton (Kleisli IO))) i o +type HoHMay i o = LabeledArrow (ReaderArrow FormIn (MaybeAutomaton (Kleisli IO))) i o -type WithError ex i o = LabeledArrow (ErrorArrow ex (ReaderArrow FormIn (Automaton (Kleisli IO)))) i o +type HoHErr ex i o = LabeledArrow (ErrorArrow ex (ReaderArrow FormIn (Automaton (Kleisli IO)))) i o +type HoHErrMay ex i o = LabeledArrow (ErrorArrow ex (ReaderArrow FormIn (MaybeAutomaton (Kleisli IO)))) i o + noInput :: FormIn noInput = FormIn [] filterPrefix :: String -> FormIn -> FormIn -filterPrefix s (FormIn xss) = FormIn $ filter ((== s) . fst) xss +filterPrefix s (FormIn xss) = trace (show (s, xss)) $ + FormIn $ filter ((== s) . fst) xss class HasFormOut o where getFormOut :: o -> FormOut @@ -46,17 +51,29 @@ getSingle (FormIn [(_,x)]) = Just x getSingle _ = Nothing -withInput :: (ArrowReader FormIn a', ArrowAddLabel a a') + +withInput + :: (ArrowReader FormIn a', + ArrowAddLabel a a', + ArrowAddAutomaton a1 a' a'1) => + a1 (e, String, Maybe String) b -> a e b +withInput = withInput0 . restify + +withInput0 :: (ArrowReader FormIn a', + ArrowAddLabel a a') => a' (e,String,Maybe String) b -> a e b -withInput f = runLabel $ proc (e,lab) -> do +withInput0 f = runLabel $ proc (e,lab) -> do fi <- readState -< () f -< (e,show lab,getSingle $ filterPrefix (show lab) fi) +restify g = liftMaybeAutomaton $ proc (e,lab,inp) -> do + (o,g') <- elimAutomaton g -< (e,lab,inp) + case inp of + Nothing -> returnA -< (o,Nothing) + _ -> returnA -< (o, Just g') + catchAuto - :: (ArrowAddAutomaton a a', - ArrowApply a', - ArrowChoice a', - ArrowChoice a) => + :: (ArrowAddAutomaton a may a') => (LabeledArrow (ErrorArrow (LabeledArrow a i o) a)) i o -> LabeledArrow a i o catchAuto f = liftAutomaton $ @@ -65,6 +82,18 @@ >>> second (arr catchAuto)) `elimError` (LabeledArrow $ proc (i,f') -> app -< (unLA (elimAutomaton f'), i)) + +catchMayAuto + :: (ArrowAddAutomaton a may a') => + LabeledArrow (ErrorArrow (LabeledArrow a t1 o) may) t1 o + -> LabeledArrow may t1 o +catchMayAuto f = liftMaybeAutomaton $ + (LabeledArrow $ + unLA (elimMaybeAutomaton f) + >>> second (arr (fmap (fromMaybeAutomaton . catchMayAuto . toMaybeAutomaton) ))) `elimError` + (LabeledArrow $ proc (i,f') -> do + (o,g) <- app -< (elimAutomaton $ unLA f', i) + returnA -< (o, Just $ LabeledArrow g)) runHamlet :: (Arrow a) => a (x -> y) y runHamlet = arr ($ undefined) diff --git a/Web/Horse/Hack.hs b/Web/Horse/Hack.hs --- a/Web/Horse/Hack.hs +++ b/Web/Horse/Hack.hs @@ -3,6 +3,10 @@ module Web.Horse.Hack where import Web.Horse.Forms +import Data.Time.Clock +import Data.Maybe +import Data.List +import Data.Function import Text.Hamlet import Web.Horse.Forms.Types import Hack ( Env (..), Response (..) ) @@ -16,6 +20,8 @@ import Control.Monad import Data.List.Split (splitOn) import Control.Arrow.Transformer.Automaton +import Control.Arrow.Transformer.Automaton.Maybe +import Control.Arrow.Transformer.Automaton.Monad import Control.Arrow.Transformer.Reader import Hack.Handler.EvHTTP (run) import Control.Arrow.Transformer.LabeledArrow @@ -25,42 +31,58 @@ runHorse f = runHorse1 run (simpleReqResp g) where - g = runReader $ runLabeledArrow f >>> arr renderHtml + g = runReader $ runLabeledArrow $ f + >>> arr renderHtml runHorse1 :: ((Env -> IO Response) -> IO ()) -> - Automaton (Kleisli IO) Env Response -> IO () + MaybeAutomaton (Kleisli IO) Env Response -> IO () runHorse1 runner f = do - mv <- newMVar M.empty + mv <- newMVar [] runner (runWeb mv f) +sessionTarget = 150 + runWeb - :: MVar (M.Map String (MVar (Automaton (Kleisli IO) Env Response))) - -> Automaton (Kleisli IO) Env Response + :: MVar [(String, MVar (Automaton (Kleisli IO) Env Response))] + -> MaybeAutomaton (Kleisli IO) Env Response -> Env -> IO Response runWeb mv f0 req = do - (mv_sess, cookie) <- getSessionMVar mv f0 req - sess <- takeMVar mv_sess - (resp,sess') <- runKleisli (auto sess) req - putMVar mv_sess sess' - return (resp{ headers= cookie ++ headers resp }) + compact mv + mv_sess <- getSessionMVar mv req + case mv_sess of + Just mv_sess -> modifyMVar mv_sess $ \sess -> do + (x,y) <- (runKleisli (auto sess) req) + return (y,x) + Nothing -> do + (resp,f') <- runKleisli (mAut f0) req + case f' of + Nothing -> return resp + Just f' -> do + (newSess :: Int) <- abs <$> randomIO + var <- newMVar f' + modifyMVar_ mv $ return . ((show newSess,var) :) + let cookie = ("Set-Cookie", + sessionName ++ "=" ++ show newSess ++ "; path=/") + print ("Set cookie " ++ show newSess) + return (resp{ headers=(cookie:headers resp) }) + +compact mv = modifyMVar_ mv $ \lst -> + case length lst > (2 * sessionTarget) of + True -> return (take sessionTarget $ nubBy ((==) `on` fst) lst) + False -> return lst + getSessionMVar - :: MVar (M.Map String (MVar a)) - -> a + :: MVar [(String, MVar (Automaton (Kleisli IO) Env Response))] -> Env - -> IO (MVar a, [(String, String)]) -getSessionMVar mv f0 req = do - let sess = lookup sessionName (cookies req) - mp <- takeMVar mv - case join $ M.lookup <$> sess <*> (Just mp) of - Just val -> putMVar mv mp >> return (val,[]) - Nothing -> do - (newSess :: Int) <- abs <$> randomIO - var <- newMVar f0 - putMVar mv (M.insert (show newSess) var mp) - return (var, [("Set-Cookie", - sessionName ++ "=" ++ show newSess ++ "; path=/")]) + -> IO (Maybe (MVar (Automaton (Kleisli IO) Env Response))) +getSessionMVar mv req = modifyMVar mv $ \lst -> do + case lookup sessionName (cookies req) of + Just sess -> case lookup sess lst of + Just val -> return ((sess,val):lst, Just val) + Nothing -> return (lst, Nothing) + Nothing -> return (lst, Nothing) sessionName :: [Char] sessionName = "HaskellOnAHorse" diff --git a/on-a-horse.cabal b/on-a-horse.cabal --- a/on-a-horse.cabal +++ b/on-a-horse.cabal @@ -7,16 +7,16 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1 +Version: 0.2 -- A short (one-line) description of the package. Synopsis: "Haskell on a Horse" - A combinatorial web framework -- A longer description of the package. -Description: Please read the introduction at http://haskell.on-a-horse.org +Description: Please read the introduction at on-a-horse.org -- URL for the project homepage or repository. -Homepage: haskell.on-a-horse.org +Homepage: http://haskell.on-a-horse.org -- The license under which the package is released. License: BSD3 @@ -52,12 +52,13 @@ Library -- Modules exported by the library. Exposed-modules: Web.Horse, Control.Arrow.Transformer.LabeledArrow, - Control.Arrow.Transformer.Automaton.Monad + Control.Arrow.Transformer.Automaton.Monad, + Control.Arrow.Transformer.Automaton.Maybe -- Packages needed in order to build this package. Build-depends: base >= 4 && < 5, safe, split, hamlet, hack, hack-handler-evhttp, hack-contrib, containers, - arrows, mtl, random, bytestring + arrows, mtl, random, bytestring, time -- Modules not exported by this package. Other-modules: Web.Horse.Forms, Web.Horse.Hack, diff --git a/tutorial.lhs b/tutorial.lhs --- a/tutorial.lhs +++ b/tutorial.lhs @@ -28,7 +28,7 @@ cabal install on-a-horse -> {-#LANGUAGE Arrows, QuasiQuotes, ScopedTypeVariables #-} +> {-#LANGUAGE Arrows, QuasiQuotes, ScopedTypeVariables, NoMonomorphismRestriction #-} > import Web.Horse > import Control.Applicative > import Control.Arrow @@ -70,7 +70,7 @@
-> ex2 :: HoH Url (Html ()) +> ex2 :: HoHMay Url (Html ()) > ex2 = proc url -> do > (fo1, oper) <- enumForm "operation" > [("times", (*)), @@ -111,7 +111,7 @@
-> ex3 :: HoH Url (Html ()) +> ex3 :: HoHMay Url (Html ()) > ex3 = formSum "example to run" [("example 1",ex1),("example 2",ex2)] mempty > >>> arr wrapForm @@ -136,14 +136,14 @@ > %input!type=submit > %br |] > where -> term :: String -> HoH () (FormOut, Maybe Integer) -> term label = catchAuto $ formSum label +> term :: String -> HoHMay () (FormOut, Maybe Integer) +> term label = catchMayAuto $ formSum label > [("number", number label), > ("add",oper label "add" (+)), > ("multiply",oper label "multiply" (*))] (mempty, Nothing) > -> number :: String -> WithError (HoH () (FormOut, Maybe Integer)) -> () (FormOut, Maybe Integer) +> number :: String -> HoHErrMay (HoH () (FormOut, Maybe Integer)) +> () (FormOut, Maybe Integer) > number termLabel = proc () -> do > fo1 <- linkForm "cancel" (term termLabel) -< () > (fo2,x) <- readForm "number" -< ()