diff --git a/happstack-dlg.cabal b/happstack-dlg.cabal --- a/happstack-dlg.cabal +++ b/happstack-dlg.cabal @@ -1,5 +1,5 @@ Name: happstack-dlg -Version: 0.1.1 +Version: 0.1.2 Cabal-Version: >= 1.2 Synopsis: Cross-request user interactions for Happstack Description: A mechanism for user interactions that extend through @@ -17,7 +17,9 @@ Library Build-Depends: base <5, containers, mtl, happstack-server, time, random, - template-haskell - Exposed-Modules: Happstack.Server.Dialogs, - Happstack.Server.Dialogs.Scaffold + template-haskell, formlets, xhtml, + applicative-extras, bytestring + Exposed-Modules: Happstack.Server.Dialogues, + Happstack.Server.Dialogues.Scaffold, + Happstack.Server.Dialogues.Formlets Hs-Source-Dirs: src diff --git a/src/Happstack/Server/Dialogs.hs b/src/Happstack/Server/Dialogs.hs deleted file mode 100644 --- a/src/Happstack/Server/Dialogs.hs +++ /dev/null @@ -1,212 +0,0 @@ -module Happstack.Server.Dialogs ( - Dlg, - Page, - perform, - showPage, - DialogManager, - makeDialogManager, - closeDialogManager, - dialog - ) - where - -import Happstack.Server -import Control.Monad.Trans -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.MVar -import Data.Maybe -import Data.Char -import Data.Time -import System.Random - -import Data.Map (Map) -import qualified Data.Map as M - -{-| - A value of a 'Dlg' type represents a dialog between the user and the application, - after which the application builds a value of type 'a'. The trivial case is that - the value is already known. Alternatively, it may be that there is some action to - be performed, or else that the user needs to be asked or told something. --} -data Dlg m a = Done a - | Action (ServerPartT m (Dlg m a)) - | Step (Page m) (Dlg m a) - -{-| - A value of 'Page' type represents a way of rendering a page, given a unique ID - that should be included in responses in order to reassociate the response with the - current dialog. --} -type Page m = Int -> ServerPartT m Response - -{- - Dlg is a monad in the obvious way: return represents a dialog that has no - steps; and (>>=) combines dialogs by doing the first part of the first - dialog, and then continuing with the rest. --} -instance Monad m => Monad (Dlg m) where - return = Done - Done x >>= y = y x - Action x >>= y = Action (x >>= return . (>>= y)) - Step p f >>= y = Step p (f >>= y) - -instance MonadTrans Dlg where - lift = Action . lift . (>>= return . Done) - -instance MonadIO m => MonadIO (Dlg m) where - liftIO = lift . liftIO - -{- - Converts a 'ServerPartT' into a Dlg. This is essentially a mechanism for - escaping the confines of the dialog mechanism and performing your own - processing with the request. --} -perform :: Monad m => ServerPartT m a -> Dlg m a -perform x = Action (x >>= return . Done) - -{-| - Converts methods for rendering and parsing the result of a page into a - 'Dlg' step. --} -showPage :: Monad m => Page m -> ServerPartT m a -> Dlg m a -showPage p r = Step p (Action (fmap Done r)) - -{-| - A 'DialogSession' represents a single user's active dialogs, which are retained - for an entire session. A reaper thread clears up sessions that have not been - touched for some session timeout, so each session also stores the last time it - was touched. In addition, each session is associated with a fixed client address - and cannot be used from a different client, which avoid hijacking. --} -data DialogSession m = DialogSession { - client :: String, - lastTouched :: MVar UTCTime, - dialogs :: MVar (Map Int (Dlg m ())) - } - -{-| - A 'DialogManager' is responsible for maintaining the state for 'Dlg' sequences - for all users. To do this, it keeps for each user a session object encapsulating - their dialogs, and associates each user with a dialog using cookies. --} -data DialogManager m = DialogManager { - sessions :: MVar (Map Int (DialogSession m)), - open :: MVar Bool - } - -{-| - Determine whether a session is still valid or not. --} -goodSession :: NominalDiffTime -> (Int, DialogSession m) -> IO Bool -goodSession timeout (_, DialogSession _ tref _) = do - st <- readMVar tref - ct <- getCurrentTime - return (diffUTCTime ct st <= timeout) - -{-| - Monadic while statement, for convenience. --} -whileM :: Monad m => m Bool -> m a -> m () -whileM cond action = do - b <- cond - if b then action >> whileM cond action else return () - -{-| - Create a new 'DialogManager' to manage a set of dialogs in the web application. - This also spawns the session reaper, which cleans up sessions that haven't been - touched for a given time period. --} -makeDialogManager :: NominalDiffTime -> IO (DialogManager m) -makeDialogManager timeout = do - oref <- newMVar True - sref <- newMVar M.empty - forkIO $ whileM (readMVar oref) $ do - threadDelay 5000 - sessionMap <- takeMVar sref - goodSessions <- filterM (goodSession timeout) (M.assocs sessionMap) - putMVar sref (M.fromList goodSessions) - return (DialogManager { sessions = sref, open = oref }) - -{-| - Closes a DialogManager, which will cause it to cease accepting any incoming - requests, and also to terminate the session reaper thread. --} -closeDialogManager :: DialogManager m -> IO () -closeDialogManager (DialogManager _ oref) = swapMVar oref False >> return () - -{-| - Given a 'Map' with a key type that can be randomly chosen, returns a key - that is not currently in the map. --} -uniqueKey :: (Random k, Ord k) => Map k a -> IO k -uniqueKey m = do k <- randomIO - if M.member k m then uniqueKey m else return k - -{-| - Adds a 'DialogSession' and associated cookie. This always sets a new blank - session, so should only be used when there is no session already. --} -addDialogSession :: MonadIO m => DialogManager m -> ServerPartT m (DialogSession m) -addDialogSession (DialogManager sref _) = do - rq <- askRq - (k, session) <- liftIO $ do - smap <- takeMVar sref - k <- uniqueKey smap - let (c, _) = rqPeer rq - ct <- getCurrentTime - tref <- newMVar ct - dref <- newMVar M.empty - let session = DialogSession c tref dref - putMVar sref (M.insert k session smap) - return (k, session) - addCookie (-1) (mkCookie "dlg-sid" (show k)) - return session - -{-| - Ensures that there is a 'DialogSession' for the current user, and returns it. - Adds a blank one if necessary. This also updates the last touched time for the - session, preventing it from being removed by the reaper thread for a while. --} -getDialogSession :: MonadIO m => DialogManager m -> ServerPartT m (DialogSession m) -getDialogSession dmgr@(DialogManager sref oref) = do - open <- liftIO $ readMVar oref - unless open mzero - rq <- askRq - msid <- getDataFn (lookCookieValue "dlg-sid") - case msid of - Nothing -> addDialogSession dmgr - Just sid -> do smap <- liftIO $ readMVar sref - case M.lookup (read sid) smap of - Nothing -> addDialogSession dmgr - Just s@(DialogSession { lastTouched = tref }) -> - if fst (rqPeer rq) /= client s - then addDialogSession dmgr - else liftIO $ do ct <- getCurrentTime - swapMVar tref ct - return s - -{-| - The 'dialog' function builds a 'ServerPartT' that handles a given dialog. In - general, it can be combined in normal ways with guards and such, so long as changes - in the request parameters won't cause it to be missed when future requests are made in - the same dialog. --} -dialog :: MonadIO m => DialogManager m -> Dlg m () -> ServerPartT m Response -dialog dmgr@(DialogManager sref oref) dlg = do - (DialogSession _ _ dref) <- getDialogSession dmgr - cont dref `mplus` this dref dlg - where cont dref = withDataFn (lookRead "dlg-dlgid") $ \dlgid -> do - dlgs <- liftIO $ readMVar dref - rq <- askRq - case M.lookup dlgid dlgs of - Nothing -> mzero - Just d -> this dref d - this dref (Done _) = mzero - this dref (Action a) = a >>= this dref - this dref (Step p f) = do - dlgs <- liftIO $ takeMVar dref - k <- liftIO $ uniqueKey dlgs - liftIO $ putMVar dref (M.insert k f dlgs) - p k - diff --git a/src/Happstack/Server/Dialogs/Scaffold.hs b/src/Happstack/Server/Dialogs/Scaffold.hs deleted file mode 100644 --- a/src/Happstack/Server/Dialogs/Scaffold.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Happstack.Server.Dialogs.Scaffold where - -import Happstack.Server -import Happstack.Server.Dialogs -import Language.Haskell.TH - -import Data.Char (ord) -import Data.Maybe (fromMaybe) - -escapeHtml :: String -> String -escapeHtml "" = "" -escapeHtml ('\"':cs) = """ ++ escapeHtml cs -escapeHtml ('\'':cs) = "'" ++ escapeHtml cs -escapeHtml ('&' :cs) = "&" ++ escapeHtml cs -escapeHtml ('<' :cs) = "<" ++ escapeHtml cs -escapeHtml ('>' :cs) = ">" ++ escapeHtml cs -escapeHtml (c :cs) | ord c >= 160 = "&#" ++ show (ord c) ++ ";" ++ escapeHtml cs - | otherwise = c : escapeHtml cs - -{-| - The 'scaffold' function builds a user interaction to display and collect information. - In a finished web application, this should generally be replaced with a better - mechanism for rendering pages, such as a templating engine, XSLT, or something - of the sort. --} -scaffold :: (Scaffolded a, Monad m) => String -> a -> Dlg m a -scaffold s v = showPage out inp - where out n = return $ setHeader "Content-type" "text/html" $ toResponse $ - "" - ++ escapeHtml s ++ "
" - ++ "
" - ++ render "dlg-vals" v - ++ "" - ++ "" - ++ "" - ++ "
" - ++ "" - inp = parse "dlg-vals" - -{-| - The 'Scaffolded' type class represents data that can be included in a form. - To make it easy to compose several of these in a page, rendering and parsing - are parameterized with prefix strings so that they may be made unique across - a page. --} -class Scaffolded a where - render :: String -> a -> String - parse :: Monad m => String -> ServerPartT m a - -instance Scaffolded () where - render _ () = "" - parse _ = return () - -instance Scaffolded String where - render pfx s = "" - parse pfx = fmap (fromMaybe "") $ getDataFn (look pfx) - -instance Scaffolded Bool where - render pfx v = "" - parse pfx = fmap (maybe False (const True)) $ getDataFn (look pfx) - -instance Scaffolded Int where - render pfx s = render pfx (show s) - parse pfx = fmap read $ parse pfx - -instance (Scaffolded a, Scaffolded b) => Scaffolded (a, b) where - render pfx (x,y) = render (pfx ++ "_1") x ++ "
" - ++ render (pfx ++ "_2") y ++ "
" - parse pfx = do x <- parse (pfx ++ "_1") - y <- parse (pfx ++ "_2") - return (x,y) - -instance (Scaffolded a, Scaffolded b, Scaffolded c) - => Scaffolded (a, b, c) where - render pfx (x,y,z) = render (pfx ++ "_1") x ++ "
" - ++ render (pfx ++ "_2") y ++ "
" - ++ render (pfx ++ "_3") z ++ "
" - parse pfx = do x <- parse (pfx ++ "_1") - y <- parse (pfx ++ "_2") - z <- parse (pfx ++ "_3") - return (x,y,z) - -{- -deriveScaffolded :: [Name] -> Q [Dec] -deriveScaffolded = mapM $ \n -> return $ - InstanceD [] (AppT (ConT (mkName "Scaffolded")) (ConT n)) [] --} diff --git a/src/Happstack/Server/Dialogues.hs b/src/Happstack/Server/Dialogues.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Dialogues.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Happstack.Server.Dialogues ( + Dlg, + Page, + perform, + showPage, + DialogueManager, + makeDialogueManager, + closeDialogueManager, + dialogue + ) + where + +import Happstack.Server +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Concurrent +import Control.Concurrent.MVar +import Data.Maybe +import Data.Char +import Data.Time +import Data.List +import System.Random + +import Data.Map (Map) +import qualified Data.Map as M + +{-| + A value of a 'Dlg' type represents a dialogue between the user and the + application, after which the application builds a value of type 'a'. The + trivial case is that the value is already known. Alternatively, it may be + that there is some action to be performed, or else that the user needs to + be asked or told something. +-} +data Dlg m a = Done a + | Action (ServerPartT m (Dlg m a)) + | Step (Page m) (Dlg m a) + +{-| + A value of 'Page' type represents a way of rendering a page, given a request URI + that should be used for subsequent requests in order to reassociate them with the + current dialogue. +-} +type Page m = String -> ServerPartT m Response + +{- + Dlg is a monad in the obvious way: return represents a dialogue that has no + steps; and (>>=) combines dialogues by doing the first part of the first + dialogue, and then continuing with the rest. +-} +instance Monad m => Monad (Dlg m) where + return = Done + Done x >>= y = y x + Action x >>= y = Action (x >>= return . (>>= y)) + Step p f >>= y = Step p (f >>= y) + +instance MonadTrans Dlg where + lift = Action . lift . (>>= return . Done) + +instance MonadIO m => MonadIO (Dlg m) where + liftIO = lift . liftIO + +{- + Converts a 'ServerPartT' into a Dlg. This is essentially a mechanism for + escaping the confines of the dialogue mechanism and performing your own + processing with the request. +-} +perform :: Monad m => ServerPartT m a -> Dlg m a +perform x = Action (x >>= return . Done) + +{-| + Converts methods for rendering and parsing the result of a page into a + 'Dlg' step. +-} +showPage :: Monad m => Page m -> ServerPartT m a -> Dlg m a +showPage p r = Step p (Action (fmap Done r)) + +{-| + A 'DialogueSession' represents a single user's active dialogs, which are + retained for an entire session. A reaper thread clears up sessions that + have not been touched for some session timeout, so each session also + stores the last time it was touched. In addition, each session is + associated with a fixed client address and cannot be used from a different + client, which avoids hijacking. +-} +data DialogueSession m = DialogueSession { + client :: String, + lastTouched :: MVar UTCTime, + dialogues :: MVar (Map Int (Dlg m ())) + } + +{-| + A 'DialogueManager' is responsible for maintaining the state for 'Dlg' + sequences for all users. To do this, it keeps for each user a session + object encapsulating their dialogues, and associates each user with their + session using cookies. +-} +data DialogueManager m = DialogueManager { + sessions :: MVar (Map Int (DialogueSession m)), + open :: MVar Bool + } + +{-| + Determine whether a session is still valid or not. +-} +goodSession :: NominalDiffTime -> (Int, DialogueSession m) -> IO Bool +goodSession timeout (_, DialogueSession _ tref _) = do + st <- readMVar tref + ct <- getCurrentTime + return (diffUTCTime ct st <= timeout) + +{-| + Monadic while statement, for convenience. +-} +whileM :: Monad m => m Bool -> m a -> m () +whileM cond action = do + b <- cond + if b then action >> whileM cond action else return () + +{-| + Create a new 'DialogueManager' to manage a set of dialogues in the web + application. This also spawns the session reaper, which cleans up sessions + that haven't been touched for a given time period. +-} +makeDialogueManager :: NominalDiffTime -> IO (DialogueManager m) +makeDialogueManager timeout = do + oref <- newMVar True + sref <- newMVar M.empty + forkIO $ whileM (readMVar oref) $ do + threadDelay 5000 + sessionMap <- takeMVar sref + goodSessions <- filterM (goodSession timeout) (M.assocs sessionMap) + putMVar sref (M.fromList goodSessions) + return (DialogueManager { sessions = sref, open = oref }) + +{-| + Closes a DialogueManager, which will cause it to cease accepting any + incoming requests, and also to terminate the session reaper thread. +-} +closeDialogueManager :: DialogueManager m -> IO () +closeDialogueManager (DialogueManager _ oref) = do swapMVar oref False + return () + +{-| + Given a 'Map' with a key type that can be randomly chosen, returns a key + that is not currently in the map. +-} +uniqueKey :: (Random k, Ord k) => Map k a -> IO k +uniqueKey m = do k <- randomIO + if M.member k m then uniqueKey m else return k + +{-| + Adds a 'DialogueSession' and associated cookie. This always sets a new + blank session, so should only be used when there is no session already. +-} +addDialogueSession :: MonadIO m => DialogueManager m -> + ServerPartT m (DialogueSession m) +addDialogueSession (DialogueManager sref _) = do + rq <- askRq + (k, session) <- liftIO $ do + smap <- takeMVar sref + k <- uniqueKey smap + let (c, _) = rqPeer rq + ct <- getCurrentTime + tref <- newMVar ct + dref <- newMVar M.empty + let session = DialogueSession c tref dref + putMVar sref (M.insert k session smap) + return (k, session) + addCookie (-1) (mkCookie "dlg-sid" (show k)) + return session + +{-| + Ensures that there is a 'DialogueSession' for the current user, and returns + it. Adds a blank one if necessary. This also updates the last touched + time for the session, preventing it from being removed by the reaper + thread for a while. +-} +getDialogueSession :: MonadIO m => DialogueManager m -> + ServerPartT m (DialogueSession m) +getDialogueSession dmgr@(DialogueManager sref oref) = do + open <- liftIO $ readMVar oref + unless open mzero + rq <- askRq + msid <- getDataFn (lookCookieValue "dlg-sid") + case msid of + Nothing -> addDialogueSession dmgr + Just sid -> do smap <- liftIO $ readMVar sref + case M.lookup (read sid) smap of + Nothing -> addDialogueSession dmgr + Just s@(DialogueSession { lastTouched = tref }) -> + if fst (rqPeer rq) /= client s + then addDialogueSession dmgr + else liftIO $ do ct <- getCurrentTime + swapMVar tref ct + return s + +{-| + A simple response that adds trailing slashes to a path when they don't exist. + Trailing slashes are required for dialogue paths, since a path component is used + to distinguish the dialogue ID. +-} +addTrailingSlash :: Monad m => ServerPartT m Response +addTrailingSlash = do + rq <- askRq + tempRedirect (rqUri rq ++ "/") (toResponse "Please use a trailing slash") + +{-| + Inverts a guard condition. +-} +notGuard :: (ServerMonad m, MonadPlus m) => m () -> m () +notGuard g = (g >> return mzero) `mplus` return (return ()) >>= id + +{-| + The 'dialogue' function builds a 'ServerPartT' that handles a given + dialogue. In general, it can be combined in normal ways with guards and + such, so long as changes in the request parameters won't cause it to be + missed when future requests are made in the same dialogue. +-} +dialogue :: MonadIO m => DialogueManager m -> Dlg m () + -> ServerPartT m Response +dialogue dmgr dlg = do (DialogueSession _ _ dref) <- getDialogueSession dmgr + checkForm `mplus` continue dref + `mplus` (nullDir >> handle dref (forever dlg)) + + where checkForm = nullDir >> notGuard trailingSlash >> addTrailingSlash + + continue dref = path $ \ (dlgid :: Int) -> nullDir >> do + dlgs <- liftIO $ readMVar dref + rq <- askRq + case M.lookup dlgid dlgs of + Nothing -> handle dref dlg + Just d -> handle dref d + + handle dref (Done _) = mzero + handle dref (Action a) = a >>= handle dref + handle dref (Step p f) = do + dlgs <- liftIO $ takeMVar dref + rq <- askRq + k <- liftIO $ uniqueKey dlgs + liftIO $ putMVar dref (M.insert k f dlgs) + p (rqUri rq show k) + + () :: String -> String -> String + a b = let is = elemIndices '/' a + in if null is then a ++ "/" ++ b + else take (last is) a ++ "/" ++ b + diff --git a/src/Happstack/Server/Dialogues/Formlets.hs b/src/Happstack/Server/Dialogues/Formlets.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Dialogues/Formlets.hs @@ -0,0 +1,24 @@ +module Happstack.Server.Dialogues.Formlets where + +import Happstack.Server.Dialogues + +import Text.XHtml.Strict +import Text.XHtml.Strict.Formlets hiding (hidden) +import Control.Applicative.Error (Failing (..)) + +import Happstack.Server.SimpleHTTP hiding (method) + +import Control.Monad.Identity + +showForm :: Monad m => XHtmlForm Identity a -> Dlg m (Maybe a) +showForm f = showPage render parse + where render uri = let (_, Identity html, _) = runFormState [] f + in return $ toResponse $ + form ! [method "POST", action uri] << (html + +++ submit "submit" "submit" + ) + parse = withDataFn lookPairs $ \env -> do + let (Identity x, _, _) = runFormState (map (fmap Left) env) f + case x of Success a -> return (Just a) + Failure _ -> return Nothing + diff --git a/src/Happstack/Server/Dialogues/Scaffold.hs b/src/Happstack/Server/Dialogues/Scaffold.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Dialogues/Scaffold.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Happstack.Server.Dialogues.Scaffold where + +import Happstack.Server +import Happstack.Server.Dialogues +import Language.Haskell.TH + +import qualified Data.ByteString.Lazy.Char8 as B + +import Data.Char (ord) +import Data.Maybe (fromMaybe) + +import Data.List + +escapeHtml :: String -> String +escapeHtml "" = "" +escapeHtml ('\"':cs) = """ ++ escapeHtml cs +escapeHtml ('\'':cs) = "'" ++ escapeHtml cs +escapeHtml ('&' :cs) = "&" ++ escapeHtml cs +escapeHtml ('<' :cs) = "<" ++ escapeHtml cs +escapeHtml ('>' :cs) = ">" ++ escapeHtml cs +escapeHtml (c :cs) | ord c >= 160 = "&#" ++ show (ord c) ++ ";" ++ escapeHtml cs + | otherwise = c : escapeHtml cs + +{-| + The 'scaffold' function builds a user interaction to display and collect information. + In a finished web application, this should generally be replaced with a better + mechanism for rendering pages, such as a templating engine, XSLT, or something + of the sort. +-} +scaffold :: (Scaffolded a, Monad m) => String -> a -> Dlg m a +scaffold s v = showPage out inp + where out uri = return $ setHeader "Content-type" "text/html" $ toResponse $ + "" + ++ escapeHtml s ++ "
" + ++ "
" + ++ render "dlg-vals" v + ++ "" + ++ "" + ++ "
" + ++ "" + inp = parse "dlg-vals" v + +{-| + The 'Scaffolded' type class represents data that can be included in a form. + To make it easy to compose several of these in a page, rendering and parsing + are parameterized with prefix strings so that they may be made unique across + a page. +-} +class Scaffolded a where + render :: String -> a -> String + parse :: Monad m => String -> a -> ServerPartT m a + +instance Scaffolded () where + render _ () = "" + parse _ _ = return () + +instance Scaffolded String where + render pfx s = "" + parse pfx _ = fmap (fromMaybe "") $ getDataFn (look pfx) + +instance Scaffolded B.ByteString where + render pfx s = "
" + parse pfx _ = do x <- getDataFn (lookInput pfx) + case x of Just inp -> return (inputValue inp) + Nothing -> return B.empty + +instance Scaffolded Bool where + render pfx v = "" + parse pfx _ = fmap (maybe False (const True)) $ getDataFn (look pfx) + +instance Scaffolded Int where + render pfx s = render pfx (show s) + parse pfx v = fmap read $ parse pfx undefined + +instance (Scaffolded a, Scaffolded b) => Scaffolded (a, b) where + render pfx (x,y) = render (pfx ++ "_1") x ++ "
" + ++ render (pfx ++ "_2") y ++ "
" + parse pfx (x,y) = do x <- parse (pfx ++ "_1") x + y <- parse (pfx ++ "_2") y + return (x,y) + +instance (Scaffolded a, Scaffolded b, Scaffolded c) + => Scaffolded (a, b, c) where + render pfx (x,y,z) = render (pfx ++ "_1") x ++ "
" + ++ render (pfx ++ "_2") y ++ "
" + ++ render (pfx ++ "_3") z ++ "
" + parse pfx (x,y,z) = do x <- parse (pfx ++ "_1") x + y <- parse (pfx ++ "_2") y + z <- parse (pfx ++ "_3") z + return (x,y,z) + +{-| + Wrapper type to present a list of options. +-} +data Choice a = Choice [a] Int deriving Show + +toChoice :: (Bounded a, Enum a, Eq a) => a -> Choice a +toChoice x = let choices = [minBound .. maxBound] + in Choice choices (fromMaybe minBound $ elemIndex x choices) + +fromChoice :: Choice a -> a +fromChoice (Choice cs i) = cs !! i + +chooseFrom :: [a] -> Choice a +chooseFrom xs = Choice xs 0 + +instance (Eq a, Show a) => Scaffolded (Choice a) where + render pfx (Choice cs i) = concat + [ "" else ">" + ++ "
" + | (c,i') <- zip cs [0..] ] + parse pfx (Choice cs _) = fmap (Choice cs . read) $ parse pfx undefined + +{- +deriveScaffolded :: [Name] -> Q [Dec] +deriveScaffolded = mapM $ \n -> return $ + InstanceD [] (AppT (ConT (mkName "Scaffolded")) (ConT n)) [] +-} +