on-a-horse 0.1 → 0.2

raw patch · 8 files changed

+264/−81 lines, 8 filesdep +timePVP ok

version bump matches the API change (PVP)

Dependencies added: time

API changes (from Hackage documentation)

Files

• Control/Arrow/Transformer/Automaton/Maybe.hs +69/−0
• Control/Arrow/Transformer/Automaton/Monad.hs +60/−19
• Control/Arrow/Transformer/LabeledArrow.hs +11/−2
• Web/Horse/Forms.hs +27/−15
• Web/Horse/Forms/Types.hs +38/−9
• Web/Horse/Hack.hs +46/−24
• on-a-horse.cabal +6/−5
• tutorial.lhs +7/−7

@@ -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

@@ -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

@@ -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

@@ -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)  

@@ -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)

@@ -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"

@@ -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, 

@@ -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 @@   <table class=example><tr><td> -> ex2 :: HoH Url (Html ())+> ex2 :: HoHMay Url (Html ()) > ex2 =  proc url -> do >               (fo1, oper) <- enumForm "operation"  >                           [("times", (*)),@@ -111,7 +111,7 @@   <table class=example><tr><td> -> 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" -< ()