From 01cee62b10b6963852f7fa4501f8cf887c3fff95 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 Dec 2018 19:30:29 +0100 Subject: [PATCH] Work on #39 --- messages/uniworx/de.msg | 3 ++ src/Data/CaseInsensitive/Instances.hs | 5 ++ src/Data/Monoid/Instances.hs | 19 ++++++++ src/Handler/Corrections.hs | 1 + src/Handler/Course.hs | 19 +++++++- src/Handler/Home.hs | 2 + src/Handler/Profile.hs | 5 ++ src/Handler/Sheet.hs | 7 +-- src/Handler/Submission.hs | 3 +- src/Handler/SystemMessage.hs | 9 ++-- src/Handler/Term.hs | 1 + src/Handler/Users.hs | 1 + src/Handler/Utils/Form.hs | 24 +++++++++ src/Handler/Utils/Table/Pagination.hs | 51 +++++++++++++++----- src/Import/NoFoundation.hs | 1 + src/Utils/Form.hs | 2 +- templates/table/layout-filter-default.hamlet | 6 +++ templates/widgets/form.hamlet | 2 +- 18 files changed, 136 insertions(+), 25 deletions(-) create mode 100644 src/Data/Monoid/Instances.hs create mode 100644 templates/table/layout-filter-default.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1595dc8d9..340c9fa16 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -72,6 +72,8 @@ CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gese CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein +CourseFilterSearch: Volltext-Suche +CourseFilterRegistered: Registriert NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -233,6 +235,7 @@ CorrUpload: Korrekturen hochladen CorrSetCorrector: Korrektor zuweisen CorrAutoSetCorrector: Korrekturen verteilen NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! +JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure} SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist): diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 7dc9123e8..c9e7f0c5d 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.CaseInsensitive.Instances @@ -20,6 +21,8 @@ import Language.Haskell.TH.Syntax (Lift(..)) import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..)) +import qualified Database.Esqueleto as E + instance PersistField (CI Text) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText @@ -37,6 +40,8 @@ instance PersistFieldSql (CI Text) where instance PersistFieldSql (CI String) where sqlType _ = SqlOther "citext" +instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a) + instance ToJSON a => ToJSON (CI a) where toJSON = toJSON . CI.original diff --git a/src/Data/Monoid/Instances.hs b/src/Data/Monoid/Instances.hs new file mode 100644 index 000000000..44909d53f --- /dev/null +++ b/src/Data/Monoid/Instances.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Monoid.Instances + ( + ) where + +import ClassyPrelude +import Data.Monoid + +type instance Element (Dual a) = a +instance MonoPointed (Dual a) +type instance Element (Sum a) = a +instance MonoPointed (Sum a) +type instance Element (Product a) = a +instance MonoPointed (Product a) +type instance Element (First a) = a +instance MonoPointed (First a) +type instance Element (Last a) = a +instance MonoPointed (Last a) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 803ef4bae..b77167ca8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -277,6 +277,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) ) ] + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "corrections" :: Text } diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e843ade32..d34542f87 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -12,6 +12,8 @@ import qualified Data.Text as T import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 +import Data.Monoid (Last(..)) + import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map @@ -161,13 +163,27 @@ makeCourseTable whereClause colChoices psValidator = do | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias) ) + , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> course2Registered muid tExpr E.==. E.val needle + ) + , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + ) ] + , dbtFilterUI = mconcat + [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing + , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing + ] , dbtStyle = def , dbtIdent = "courses" :: Text } getCourseListR :: Handler Html -getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! +getCourseListR = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ colCourseDescr @@ -182,7 +198,6 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle - [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO $(widgetFile "courses") getTermCurrentR :: Handler Html diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 911827e00..f5bd47c51 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -97,6 +97,7 @@ homeAnonymous = do | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) ] -} + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "upcomingdeadlines" :: Text } @@ -198,6 +199,7 @@ homeUser uid = do | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) ] -} + , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index dab2a6b83..410f6862a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -273,6 +273,7 @@ mkOwnedCoursesTable = , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} @@ -319,6 +320,7 @@ mkEnrolledCoursesTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] + , dbtFilterUI = mempty , dbtStyle = def } @@ -396,6 +398,7 @@ mkSubmissionTable = , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid in dbTableWidget' validator DBTable{..} @@ -465,6 +468,7 @@ mkSubmissionGroupTable = , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} @@ -538,6 +542,7 @@ mkCorrectionsTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6728e11a2..f8b4b8f51 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -225,8 +225,8 @@ getSheetListR tid ssh csh = do -- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType) -- ) ] - , dbtFilter = Map.fromList - [] + , dbtFilter = mempty + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "sheets" :: Text } @@ -294,7 +294,8 @@ getSShowR tid ssh csh shn = do , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) , dbtStyle = def - , dbtFilter = Map.empty + , dbtFilter = mempty + , dbtFilterUI = mempty , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cc645a929..7129dfeeb 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -310,7 +310,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) ) ] - , dbtFilter = Map.empty + , dbtFilter = mempty + , dbtFilterUI = mempty } mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 0bde9b1c8..a71104eff 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -178,12 +178,9 @@ postMessageListR = do { dbtSQLQuery , dbtColonnade , dbtProj - , dbtSorting = Map.fromList - [ -- TODO: from, to, authenticated, severity - ] - , dbtFilter = Map.fromList - [ - ] + , dbtSorting = mempty -- TODO: from, to, authenticated, severity + , dbtFilter = mempty + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "messages" :: Text } diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 41262bd44..0b1e67100 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -126,6 +126,7 @@ getTermShowR = do E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs ) ] + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "terms" :: Text } diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ec3924508..d3a9a1d50 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -85,6 +85,7 @@ getUsersR = do ) ] , dbtFilter = mempty + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "users" :: Text } diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc16635d7..906aa48fc 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -45,6 +45,9 @@ import Text.Read (readMaybe) import Utils.Lens +import Data.Aeson (eitherDecodeStrict') +import Data.Aeson.Text (encodeToLazyText) + ---------------------------- -- Buttons (new version ) -- ---------------------------- @@ -455,6 +458,27 @@ langField :: Bool -- ^ Only allow values from `appLanguages` langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages) langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages +jsonField :: ( ToJSON a, FromJSON a + , MonadHandler m + , RenderMessage (HandlerSite m) UniWorXMessage + , RenderMessage (HandlerSite m) FormMessage + ) + => Bool {-^ Hidden? -} + -> Field m a +jsonField hide = Field{..} + where + inputType :: Text + inputType + | hide = "hidden" + | otherwise = "text" + fieldParse [v] [] = return . second Just . first (SomeMessage . MsgJSONFieldDecodeFailure) . eitherDecodeStrict' $ encodeUtf8 v + fieldParse [] [] = return $ Right Nothing + fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired + fieldView theId name attrs val isReq = liftWidgetT [whamlet| + + |] + fieldEnctype = UrlEncoded + funcForm :: forall k v m. ( Finite k, Ord k diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 808ad04af..170d52bbd 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination ) where import Handler.Utils.Table.Pagination.Types +import Handler.Utils.Form import Utils import Utils.Lens.TH @@ -228,6 +229,11 @@ data DBStyle = DBStyle { dbsEmptyStyle :: DBEmptyStyle , dbsEmptyMessage :: UniWorXMessage , dbsAttrs :: [(Text, Text)] + , dbsLayoutFilter :: Widget -- ^ Filter UI + -> Enctype + -> Text -- ^ Filter action (target uri) + -> Widget -- ^ Table + -> Widget } instance Default DBStyle where @@ -235,8 +241,12 @@ instance Default DBStyle where { dbsEmptyStyle = def , dbsEmptyMessage = MsgNoTableContent , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ] + , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default") } +type FilterKey = CI Text +type SortingKey = CI Text + data DBTable m x = forall a r r' h i t. ( ToSortable h, Functor h , E.SqlSelect a r @@ -246,8 +256,9 @@ data DBTable m x = forall a r r' h i t. { dbtSQLQuery :: t -> E.SqlQuery a , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r' , dbtColonnade :: Colonnade h r' (DBCell m x) - , dbtSorting :: Map (CI Text) (SortColumn t) - , dbtFilter :: Map (CI Text) (FilterColumn t) + , dbtSorting :: Map SortingKey (SortColumn t) + , dbtFilter :: Map FilterKey (FilterColumn t) + , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) , dbtStyle :: DBStyle , dbtIdent :: i } @@ -379,18 +390,31 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldEnctype = UrlEncoded } - piResult <- lift . runInputGetResult $ PaginationInput + piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + + piInput <- lift . runInputGetResult $ PaginationInput <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) <*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "page") - piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + let filterPi + | FormSuccess PaginationInput{..} <- piPrevious <|> piInput + = def{ piSorting, piLimit } + | otherwise + = def + + ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,) + <$> areq (jsonField True) "" (Just filterPi) + <*> dbtFilterUI + + let + piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit let - (errs, PaginationSettings{..}) = case piPrevious <|> piResult of + (errs, PaginationSettings{..}) = case piResult of FormSuccess pi | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi @@ -398,7 +422,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing _ -> runPSValidator dbtable Nothing paginationInput - | FormSuccess pi <- piPrevious <|> piResult + | FormSuccess pi <- piResult , not $ piIsUnset pi = pi | otherwise @@ -419,18 +443,23 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' + getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + let rowCount | (E.Value n, _):_ <- rows' = n | otherwise = 0 + tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams + + filterAction = tblLink + $ setParam (wIdent "page") Nothing + . Map.foldrWithKey (\k _ f -> setParam (wIdent $ CI.foldedCase k) Nothing . f) id dbtFilter + table' :: WriterT x m Widget table' = do - getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest let - tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams - genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do widget <- sortableContent ^. cellContents let @@ -456,7 +485,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return $(widgetFile "table/layout") - bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' + bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' where tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html tblLayout tbl' = do @@ -464,7 +493,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet") setParam :: Text -> Maybe Text -> QueryText -> QueryText - setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] + setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ] dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x -> DB (DBResult (HandlerT UniWorX IO) x) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 3bd7ebc45..a832df0db 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -41,6 +41,7 @@ import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) +import Data.Monoid.Instances as Import () import Control.Monad.Morph as Import (MFunctor(..)) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5450e0f40..c754bf227 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -28,7 +28,7 @@ import Utils.Message ------------------- -- | Use this type to pass information to the form template -data FormLayout = FormStandard +data FormLayout = FormStandard | FormDBTableFilter renderAForm :: Monad m => FormLayout -> FormRender m a renderAForm formLayout aform fragment = do diff --git a/templates/table/layout-filter-default.hamlet b/templates/table/layout-filter-default.hamlet new file mode 100644 index 000000000..9291c30fb --- /dev/null +++ b/templates/table/layout-filter-default.hamlet @@ -0,0 +1,6 @@ +$newline never +
+
+ ^{filterWgdt} +
+ ^{scrolltable} diff --git a/templates/widgets/form.hamlet b/templates/widgets/form.hamlet index 79c2178a6..50d90cbb3 100644 --- a/templates/widgets/form.hamlet +++ b/templates/widgets/form.hamlet @@ -1,7 +1,7 @@ $newline never #{fragment} $case formLayout - $of FormStandard + $of _ $forall view <- views $# TODO: add class 'form-group--submit' if this is the submit-button view