diff --git a/src/Foundation.hs b/src/Foundation.hs index b162056aa..67e9a8933 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -139,10 +139,10 @@ instance Yesod UniWorX where } ] - let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] + let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] let navbarRightMenuItems = [x | NavbarRight x <- menuItems] - let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] + let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems , menuItemAccessCallback x] let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] -- We break up the default layout into two components: diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9702b4cad..b08062b94 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -10,6 +10,8 @@ module Handler.Utils.Form where import Import -- import Data.Time +import Data.Proxy +import qualified Data.Map as Map import Handler.Utils.DateTime import Data.String (IsString(..)) @@ -19,10 +21,73 @@ import qualified Data.Text as T import Yesod.Form.Functions (parseHelper) import Yesod.Form.Bootstrap3 +import Web.PathPieces (showToPathPiece, readFromPathPiece) +import Text.Blaze (Markup) +---------------------------- +-- Buttons (new version ) -- +---------------------------- -------------- --- Buttons -- -------------- +class (Enum a, Bounded a, PathPiece a) => Button a where + label :: a -> Widget + label = toWidget . toPathPiece + +data CreateButton = CreateMath | CreateInf + deriving (Enum, Bounded, Read, Show) + + +instance PathPiece CreateButton where + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece + +instance Button CreateButton + + +-- buttonForm :: (Monad m, Button a) => a -> Markup -> MForm m (FormResult (Maybe a), (a -> Widget)) +-- buttonForm :: (Monad m, Button a) => a -> Markup -> MForm m (FormResult (Maybe a), (a -> WidgetT (HandlerSite m) IO ())) +-- buttonForm :: (Monad m, Button a) => a -> MForm m a +{- Inference yields this monster: +buttonForm + :: (HandlerSite m ~ UniWorX, Ord k, Text.Blaze.ToMarkup a, + Button (Either Text k), MonadHandler m, Enum k, Bounded k, + PathPiece k) => + Data.Proxy.Proxy k + -> a + -> Control.Monad.Trans.RWS.Lazy.RWST + (Maybe (Env, FileEnv), HandlerSite m, [Lang]) + Enctype + Ints + m + (FormResult (Maybe k), k -> FieldView (HandlerSite m)) + -} +buttonForm btn html = do + let + buttonValues = [(minBound `asProxyTypeOf` btn)..maxBound] + buttonMap = Map.fromList $ zip buttonValues buttonValues + button val = Field parse view UrlEncoded + where + parse [] _ = return $ Right Nothing + parse [str] _ + | str == toPathPiece val = return $ Right $ Just val + | otherwise = return $ Left "Wrong button value" + parse _ _ = return $ Left "Multiple button values" + + view id name attrs val _ = do + [whamlet| + #{html} +