Dropped support for older versions of yesod and warp than the ones in Debian Jessie.
466 lines of compat cruft deleted!
This commit is contained in:
Joey Hess
parent
a15e1158c6
commit
eb8ef44133
13 changed files with 19 additions and 466 deletions
|
|
@ -1,260 +0,0 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | Helper functions for creating forms when using Bootstrap v3.
|
||||
-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
|
||||
-- modified to be compatible with Yesod 1.0.1
|
||||
module Assistant.WebApp.Bootstrap3
|
||||
( -- * Rendering forms
|
||||
renderBootstrap3
|
||||
, BootstrapFormLayout(..)
|
||||
, BootstrapGridOptions(..)
|
||||
-- * Field settings
|
||||
, bfs
|
||||
, withPlaceholder
|
||||
, withAutofocus
|
||||
, withLargeInput
|
||||
, withSmallInput
|
||||
-- * Submit button
|
||||
, bootstrapSubmit
|
||||
, mbootstrapSubmit
|
||||
, BootstrapSubmit(..)
|
||||
) where
|
||||
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (liftM)
|
||||
import Data.Text (Text)
|
||||
import Data.String (IsString(..))
|
||||
import Yesod.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Functions
|
||||
|
||||
-- | Create a new 'FieldSettings' with the classes that are
|
||||
-- required by Bootstrap v3.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
bfs :: RenderMessage site msg => msg -> FieldSettings site
|
||||
bfs msg =
|
||||
FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
|
||||
|
||||
|
||||
-- | Add a placeholder attribute to a field. If you need i18n
|
||||
-- for the placeholder, currently you\'ll need to do a hack and
|
||||
-- use 'getMessageRender' manually.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
|
||||
withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
|
||||
where newAttrs = ("placeholder", placeholder) : fsAttrs fs
|
||||
|
||||
|
||||
-- | Add an autofocus attribute to a field.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
withAutofocus :: FieldSettings site -> FieldSettings site
|
||||
withAutofocus fs = fs { fsAttrs = newAttrs }
|
||||
where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
|
||||
|
||||
|
||||
-- | Add the @input-lg@ CSS class to a field.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
withLargeInput :: FieldSettings site -> FieldSettings site
|
||||
withLargeInput fs = fs { fsAttrs = newAttrs }
|
||||
where newAttrs = addClass "input-lg" (fsAttrs fs)
|
||||
|
||||
|
||||
-- | Add the @input-sm@ CSS class to a field.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
withSmallInput :: FieldSettings site -> FieldSettings site
|
||||
withSmallInput fs = fs { fsAttrs = newAttrs }
|
||||
where newAttrs = addClass "input-sm" (fsAttrs fs)
|
||||
|
||||
|
||||
addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
|
||||
addClass klass [] = [("class", klass)]
|
||||
addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
|
||||
addClass klass (other :rest) = other : addClass klass rest
|
||||
|
||||
|
||||
-- | How many bootstrap grid columns should be taken (see
|
||||
-- 'BootstrapFormLayout').
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
data BootstrapGridOptions =
|
||||
ColXs !Int
|
||||
| ColSm !Int
|
||||
| ColMd !Int
|
||||
| ColLg !Int
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
toColumn :: BootstrapGridOptions -> String
|
||||
toColumn (ColXs 0) = ""
|
||||
toColumn (ColSm 0) = ""
|
||||
toColumn (ColMd 0) = ""
|
||||
toColumn (ColLg 0) = ""
|
||||
toColumn (ColXs columns) = "col-xs-" ++ show columns
|
||||
toColumn (ColSm columns) = "col-sm-" ++ show columns
|
||||
toColumn (ColMd columns) = "col-md-" ++ show columns
|
||||
toColumn (ColLg columns) = "col-lg-" ++ show columns
|
||||
|
||||
toOffset :: BootstrapGridOptions -> String
|
||||
toOffset (ColXs 0) = ""
|
||||
toOffset (ColSm 0) = ""
|
||||
toOffset (ColMd 0) = ""
|
||||
toOffset (ColLg 0) = ""
|
||||
toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
|
||||
toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
|
||||
toOffset (ColMd columns) = "col-md-offset-" ++ show columns
|
||||
toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
|
||||
|
||||
addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
|
||||
addGO (ColXs a) (ColXs b) = ColXs (a+b)
|
||||
addGO (ColSm a) (ColSm b) = ColSm (a+b)
|
||||
addGO (ColMd a) (ColMd b) = ColMd (a+b)
|
||||
addGO (ColLg a) (ColLg b) = ColLg (a+b)
|
||||
addGO a b | a > b = addGO b a
|
||||
addGO (ColXs a) other = addGO (ColSm a) other
|
||||
addGO (ColSm a) other = addGO (ColMd a) other
|
||||
addGO (ColMd a) other = addGO (ColLg a) other
|
||||
addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here"
|
||||
|
||||
|
||||
-- | The layout used for the bootstrap form.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
data BootstrapFormLayout =
|
||||
BootstrapBasicForm
|
||||
| BootstrapInlineForm
|
||||
| BootstrapHorizontalForm
|
||||
{ bflLabelOffset :: !BootstrapGridOptions
|
||||
, bflLabelSize :: !BootstrapGridOptions
|
||||
, bflInputOffset :: !BootstrapGridOptions
|
||||
, bflInputSize :: !BootstrapGridOptions
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
-- | Render the given form using Bootstrap v3 conventions.
|
||||
--
|
||||
-- Sample Hamlet for 'BootstrapHorizontalForm':
|
||||
--
|
||||
-- > <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
|
||||
-- > ^{formWidget}
|
||||
-- > ^{bootstrapSubmit MsgSubmit}
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
|
||||
renderBootstrap3 formLayout aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
has (Just _) = True
|
||||
has Nothing = False
|
||||
widget = [whamlet|
|
||||
#{fragment}
|
||||
$forall view <- views
|
||||
<div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
|
||||
$case formLayout
|
||||
$of BootstrapBasicForm
|
||||
$if nequals (fvId view) bootstrapSubmitId
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
^{fvInput view}
|
||||
^{helpWidget view}
|
||||
$of BootstrapInlineForm
|
||||
$if nequals (fvId view) bootstrapSubmitId
|
||||
<label .sr-only for=#{fvId view}>#{fvLabel view}
|
||||
^{fvInput view}
|
||||
^{helpWidget view}
|
||||
$of BootstrapHorizontalForm _a _b _c _d
|
||||
$if nequals (fvId view) bootstrapSubmitId
|
||||
<label .control-label .#{toOffset (bflLabelOffset formLayout)} .#{toColumn (bflLabelSize formLayout)} for=#{fvId view}>#{fvLabel view}
|
||||
<div .#{toOffset (bflInputOffset formLayout)} .#{toColumn (bflInputSize formLayout)}>
|
||||
^{fvInput view}
|
||||
^{helpWidget view}
|
||||
$else
|
||||
<div .#{toOffset (addGO (bflInputOffset formLayout) (addGO (bflLabelOffset formLayout) (bflLabelSize formLayout)))} .#{toColumn (bflInputSize formLayout)}>
|
||||
^{fvInput view}
|
||||
^{helpWidget view}
|
||||
|]
|
||||
return (res, widget)
|
||||
where
|
||||
nequals a b = a /= b -- work around older hamlet versions not liking /=
|
||||
|
||||
-- | (Internal) Render a help widget for tooltips and errors.
|
||||
helpWidget :: FieldView sub master -> GWidget sub master ()
|
||||
helpWidget view = [whamlet|
|
||||
$maybe tt <- fvTooltip view
|
||||
<span .help-block>#{tt}
|
||||
$maybe err <- fvErrors view
|
||||
<span .help-block>#{err}
|
||||
|]
|
||||
|
||||
|
||||
-- | How the 'bootstrapSubmit' button should be rendered.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
data BootstrapSubmit msg =
|
||||
BootstrapSubmit
|
||||
{ bsValue :: msg
|
||||
-- ^ The text of the submit button.
|
||||
, bsClasses :: Text
|
||||
-- ^ Classes added to the @<button>@.
|
||||
, bsAttrs :: [(Text, Text)]
|
||||
-- ^ Attributes added to the @<button>@.
|
||||
} deriving (Show)
|
||||
|
||||
instance IsString msg => IsString (BootstrapSubmit msg) where
|
||||
fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
|
||||
|
||||
|
||||
-- | A Bootstrap v3 submit button disguised as a field for
|
||||
-- convenience. For example, if your form currently is:
|
||||
--
|
||||
-- > Person <$> areq textField "Name" Nothing
|
||||
-- > <*> areq textField "Surname" Nothing
|
||||
--
|
||||
-- Then just change it to:
|
||||
--
|
||||
-- > Person <$> areq textField "Name" Nothing
|
||||
-- > <*> areq textField "Surname" Nothing
|
||||
-- > <* bootstrapSubmit "Register"
|
||||
--
|
||||
-- (Note that @<*@ is not a typo.)
|
||||
--
|
||||
-- Alternatively, you may also just create the submit button
|
||||
-- manually as well in order to have more control over its
|
||||
-- layout.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
|
||||
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
|
||||
|
||||
|
||||
-- | Same as 'bootstrapSubmit' but for monadic forms. This isn't
|
||||
-- as useful since you're not going to use 'renderBootstrap3'
|
||||
-- anyway.
|
||||
--
|
||||
-- Since: yesod-form 1.3.8
|
||||
mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
|
||||
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
|
||||
let res = FormSuccess ()
|
||||
widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
|
||||
fv = FieldView { fvLabel = ""
|
||||
, fvTooltip = Nothing
|
||||
, fvId = bootstrapSubmitId
|
||||
, fvInput = widget
|
||||
, fvErrors = Nothing
|
||||
, fvRequired = False }
|
||||
in return (res, fv)
|
||||
|
||||
|
||||
-- | A royal hack. Magic id used to identify whether a field
|
||||
-- should have no label. A valid HTML4 id which is probably not
|
||||
-- going to clash with any other id should someone use
|
||||
-- 'bootstrapSubmit' outside 'renderBootstrap3'.
|
||||
bootstrapSubmitId :: Text
|
||||
bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"
|
||||
|
|
@ -5,8 +5,6 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Assistant.WebApp.Common (module X) where
|
||||
|
||||
import Assistant.Common as X
|
||||
|
|
@ -15,9 +13,5 @@ import Assistant.WebApp.Page as X
|
|||
import Assistant.WebApp.Form as X
|
||||
import Assistant.WebApp.Types as X
|
||||
import Assistant.WebApp.RepoId as X
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
|
||||
#else
|
||||
import Utility.Yesod as X hiding (textField, passwordField, selectField, selectFieldList, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
|
||||
#endif
|
||||
import Data.Text as X (Text)
|
||||
|
|
|
|||
|
|
@ -50,18 +50,10 @@ data RepositoryPath = RepositoryPath Text
|
|||
-
|
||||
- Validates that the path entered is not empty, and is a safe value
|
||||
- to use as a repository. -}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
|
||||
#else
|
||||
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
|
||||
#endif
|
||||
repositoryPathField autofocus = Field
|
||||
#if ! MIN_VERSION_yesod_form(1,2,0)
|
||||
{ fieldParse = parse
|
||||
#else
|
||||
{ fieldParse = \l _ -> parse l
|
||||
, fieldEnctype = UrlEncoded
|
||||
#endif
|
||||
, fieldView = view
|
||||
}
|
||||
where
|
||||
|
|
|
|||
|
|
@ -86,11 +86,7 @@ mkSshInput s = SshInput
|
|||
, inputPort = sshPort s
|
||||
}
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
|
||||
#else
|
||||
sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
|
||||
#endif
|
||||
sshInputAForm hostnamefield d = normalize <$> gen
|
||||
where
|
||||
gen = SshInput
|
||||
|
|
|
|||
|
|
@ -8,28 +8,15 @@
|
|||
{-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings, RankNTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Assistant.WebApp.Form where
|
||||
|
||||
import Assistant.WebApp.Types
|
||||
import Assistant.Gpg
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
import Yesod hiding (textField, passwordField)
|
||||
import Yesod.Form.Fields as F
|
||||
#else
|
||||
import Yesod hiding (textField, passwordField, selectField, selectFieldList)
|
||||
import Yesod.Form.Fields as F hiding (selectField, selectFieldList)
|
||||
import Data.String (IsString (..))
|
||||
import Control.Monad (unless)
|
||||
import Data.Maybe (listToMaybe)
|
||||
#endif
|
||||
#if MIN_VERSION_yesod_form(1,3,8)
|
||||
import Yesod.Form.Bootstrap3 as Y hiding (bfs)
|
||||
#else
|
||||
import Assistant.WebApp.Bootstrap3 as Y hiding (bfs)
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
|
||||
{- Yesod's textField sets the required attribute for required fields.
|
||||
|
|
@ -61,60 +48,8 @@ passwordField = F.passwordField
|
|||
|]
|
||||
}
|
||||
|
||||
{- In older Yesod versions attrs is written into the <option> tag instead of the
|
||||
- surrounding <select>. This breaks the Bootstrap 3 layout of select fields as
|
||||
- it requires the "form-control" class on the <select> tag.
|
||||
- We need to change that to behave the same way as in newer versions.
|
||||
-}
|
||||
#if ! MIN_VERSION_yesod(1,2,0)
|
||||
selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
|
||||
selectFieldList = selectField . optionsPairs
|
||||
|
||||
selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
|
||||
selectField = selectFieldHelper
|
||||
(\theId name attrs inside -> [whamlet|<select ##{theId} name=#{name} *{attrs}>^{inside}|]) -- outside
|
||||
(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
|
||||
(\_theId _name _attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected>#{text}|]) -- inside
|
||||
|
||||
selectFieldHelper :: (Eq a, RenderMessage master FormMessage)
|
||||
=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())
|
||||
-> (Text -> Text -> Bool -> GWidget sub master ())
|
||||
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
|
||||
-> GHandler sub master (OptionList a) -> Field sub master a
|
||||
selectFieldHelper outside onOpt inside opts' = Field
|
||||
{ fieldParse = \x -> do
|
||||
opts <- opts'
|
||||
return $ selectParser opts x
|
||||
, fieldView = \theId name attrs val isReq -> do
|
||||
opts <- fmap olOptions $ lift opts'
|
||||
outside theId name attrs $ do
|
||||
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
|
||||
flip mapM_ opts $ \opt -> inside
|
||||
theId
|
||||
name
|
||||
((if isReq then (("required", "required"):) else id) attrs)
|
||||
(optionExternalValue opt)
|
||||
((render opts val) == optionExternalValue opt)
|
||||
(optionDisplay opt)
|
||||
}
|
||||
where
|
||||
render _ (Left _) = ""
|
||||
render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
|
||||
selectParser _ [] = Right Nothing
|
||||
selectParser opts (s:_) = case s of
|
||||
"" -> Right Nothing
|
||||
"none" -> Right Nothing
|
||||
x -> case olReadExternal opts x of
|
||||
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
|
||||
Just y -> Right $ Just y
|
||||
#endif
|
||||
|
||||
{- Makes a note widget be displayed after a field. -}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
|
||||
#else
|
||||
withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
|
||||
#endif
|
||||
withNote field note = field { fieldView = newview }
|
||||
where
|
||||
newview theId name attrs val isReq =
|
||||
|
|
@ -122,11 +57,7 @@ withNote field note = field { fieldView = newview }
|
|||
in [whamlet|^{fieldwidget} <span>^{note}</span>|]
|
||||
|
||||
{- Note that the toggle string must be unique on the form. -}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v
|
||||
#else
|
||||
withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
|
||||
#endif
|
||||
withExpandableNote field (toggle, note) = withNote field $ [whamlet|
|
||||
<a .btn .btn-default data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
|
||||
<div ##{ident} .collapse>
|
||||
|
|
@ -136,11 +67,7 @@ withExpandableNote field (toggle, note) = withNote field $ [whamlet|
|
|||
ident = "toggle_" ++ toggle
|
||||
|
||||
{- Adds a check box to an AForm to control encryption. -}
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
|
||||
#else
|
||||
enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
|
||||
#endif
|
||||
enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption)
|
||||
where
|
||||
choices :: [(Text, EnableEncryption)]
|
||||
|
|
|
|||
|
|
@ -5,13 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
||||
|
||||
#if defined VERSION_yesod_default
|
||||
#if ! MIN_VERSION_yesod_default(1,1,0)
|
||||
#define WITH_OLD_YESOD
|
||||
#endif
|
||||
#endif
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
||||
|
||||
module Assistant.WebApp.Notifications where
|
||||
|
||||
|
|
@ -26,9 +20,7 @@ import Utility.WebApp
|
|||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
#ifndef WITH_OLD_YESOD
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
#endif
|
||||
|
||||
{- Add to any widget to make it auto-update using long polling.
|
||||
-
|
||||
|
|
@ -42,15 +34,9 @@ import qualified Data.Aeson.Types as Aeson
|
|||
-}
|
||||
autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
|
||||
autoUpdate tident geturl ms_delay ms_startdelay = do
|
||||
#ifdef WITH_OLD_YESOD
|
||||
let delay = show ms_delay
|
||||
let startdelay = show ms_startdelay
|
||||
let ident = "'" ++ T.unpack tident ++ "'"
|
||||
#else
|
||||
let delay = Aeson.String (T.pack (show ms_delay))
|
||||
let startdelay = Aeson.String (T.pack (show ms_startdelay))
|
||||
let ident = Aeson.String tident
|
||||
#endif
|
||||
$(widgetFile "notifications/longpolling")
|
||||
|
||||
{- Notifier urls are requested by the javascript, to avoid allocation
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Assistant.WebApp.Types where
|
||||
|
|
@ -83,58 +82,30 @@ instance Yesod WebApp where
|
|||
instance RenderMessage WebApp FormMessage where
|
||||
renderMessage _ _ = defaultFormMessage
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
instance LiftAnnex Handler where
|
||||
#else
|
||||
instance LiftAnnex (GHandler sub WebApp) where
|
||||
#endif
|
||||
liftAnnex a = ifM (noAnnex <$> getYesod)
|
||||
( error "internal liftAnnex"
|
||||
, liftAssistant $ liftAnnex a
|
||||
)
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
instance LiftAnnex (WidgetT WebApp IO) where
|
||||
#else
|
||||
instance LiftAnnex (GWidget WebApp WebApp) where
|
||||
#endif
|
||||
liftAnnex = liftH . liftAnnex
|
||||
|
||||
class LiftAssistant m where
|
||||
liftAssistant :: Assistant a -> m a
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
instance LiftAssistant Handler where
|
||||
#else
|
||||
instance LiftAssistant (GHandler sub WebApp) where
|
||||
#endif
|
||||
liftAssistant a = liftIO . flip runAssistant a
|
||||
=<< assistantData <$> getYesod
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
instance LiftAssistant (WidgetT WebApp IO) where
|
||||
#else
|
||||
instance LiftAssistant (GWidget WebApp WebApp) where
|
||||
#endif
|
||||
liftAssistant = liftH . liftAssistant
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
type MkMForm x = MForm Handler (FormResult x, Widget)
|
||||
#else
|
||||
type MkMForm x = MForm WebApp WebApp (FormResult x, Widget)
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
type MkAForm x = AForm Handler x
|
||||
#else
|
||||
type MkAForm x = AForm WebApp WebApp x
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
type MkField x = Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x
|
||||
#else
|
||||
type MkField x = RenderMessage master FormMessage => Field sub master x
|
||||
#endif
|
||||
|
||||
data RepoSelector = RepoSelector
|
||||
{ onlyCloud :: Bool
|
||||
|
|
@ -154,12 +125,6 @@ data RemovableDrive = RemovableDrive
|
|||
data RepoKey = RepoKey KeyId | NoRepoKey
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
#if ! MIN_VERSION_path_pieces(0,1,4)
|
||||
instance PathPiece Bool where
|
||||
toPathPiece = pack . show
|
||||
fromPathPiece = readish . unpack
|
||||
#endif
|
||||
|
||||
instance PathPiece RemovableDrive where
|
||||
toPathPiece = pack . show
|
||||
fromPathPiece = readish . unpack
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue