From e9c69e6cfb729235612f2598db3aec758be30795 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 31 Jan 2019 11:43:32 +0100 Subject: [PATCH] Plan for MassInput-Controls being buttons --- messages/uniworx/de.msg | 4 +- src/Handler/Utils/Form/MassInput.hs | 115 +++++++++++++--------------- src/Import/NoFoundation.hs | 2 + src/Numeric/Natural/Instances.hs | 13 ++++ 4 files changed, 70 insertions(+), 64 deletions(-) create mode 100644 src/Numeric/Natural/Instances.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d24a09e5c..e6e4663c5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -611,4 +611,6 @@ DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde -MassInputUpdate: Formular aktualisieren + +MassInputAddDimension: Hinzufügen +MassInputDeleteCell: Entfernen diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 36b7aea40..c24770b61 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,6 +1,8 @@ module Handler.Utils.Form.MassInput ( massInput - , BoxDimension(..), IsBoxCoord(..), Liveliness(..) + , BoxDimension(..) + , IsBoxCoord(..), boxDimension + , Liveliness(..) ) where import Import @@ -14,15 +16,23 @@ import Control.Lens hiding (universe) import Text.Blaze (Markup) -import Data.List ((!!), elemIndex) import qualified Data.Text as Text +import Data.List (genericLength, genericIndex) + data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n) class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where boxDimensions :: [BoxDimension x] boxOrigin :: x + +boxDimension :: IsBoxCoord x => Natural -> Maybe (BoxDimension x) +boxDimension n + | n < genericLength dims = Just $ genericIndex dims n + | otherwise = Nothing + where + dims = boxDimensions class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where type BoxCoord a :: * @@ -30,75 +40,55 @@ class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemi liveCoord :: BoxCoord a -> Prism' Bool a -data MassInputButton submit - = MassInputUpdate - | MassInputSubmit submit - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Bounded submit => Bounded (MassInputButton submit) where - minBound = MassInputUpdate - maxBound = MassInputSubmit maxBound - -instance (Eq submit, Finite submit) => Enum (MassInputButton submit) where - toEnum = (!!) universe - fromEnum = fromMaybe (error "fromEnum: value not found") . flip elemIndex universeF - -instance Finite submit => Universe (MassInputButton submit) where - universe = MassInputUpdate : map MassInputSubmit universeF -instance Finite submit => Finite (MassInputButton submit) - -instance PathPiece submit => PathPiece (MassInputButton submit) where - toPathPiece = \case - MassInputUpdate -> "update" - MassInputSubmit s -> "submit__" <> toPathPiece s - fromPathPiece t = inpUpdate <|> submit - where - inpUpdate = MassInputUpdate <$ guard (t == "update") - submit = do - submitT <- stripPrefix "submit__" t - MassInputSubmit <$> fromPathPiece submitT - -instance (Button UniWorX submit, Finite submit) => Button UniWorX (MassInputButton submit) where - label MassInputUpdate = [whamlet|_{MsgMassInputUpdate}|] - label (MassInputSubmit submit) = label submit - - btnValidate _ MassInputUpdate = False - btnValidate proxy (MassInputSubmit submit) = btnValidate proxy submit - - cssClass MassInputUpdate = BCDefault - cssClass (MassInputSubmit submit) = cssClass submit - - -data MassInputFieldName x +data ButtonMassInput coord = MassInputAddDimension Natural - | MassInputDeleteCell x - | MassInputCell x Text + | MassInputDeleteCell coord deriving (Eq, Ord, Read, Show, Generic, Typeable) -instance IsBoxCoord x => PathPiece (MassInputFieldName x) where +instance PathPiece coord => PathPiece (ButtonMassInput coord) where + toPathPiece = \case + MassInputAddDimension n -> "add__" <> toPathPiece n + MassInputDeleteCell c -> "delete__" <> toPathPiece c + fromPathPiece t = addDim <|> delCell + where + addDim = do + nT <- stripPrefix "add__" t + MassInputAddDimension <$> fromPathPiece nT + delCell = do + coordT <- stripPrefix "delete__" t + MassInputDeleteCell <$> fromPathPiece coordT + +instance RenderMessage UniWorX (ButtonMassInput coord) where + renderMessage f ls = \case + MassInputAddDimension _ -> mr MsgMassInputAddDimension + MassInputDeleteCell _ -> mr MsgMassInputDeleteCell + where + mr = renderMessage f ls + +instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where + btnValidate _ _ = False + + btnClasses (MassInputAddDimension _) = [BCIsButton, BCDefault] + btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning] + + +data MassInputFieldName coord + = MassInputCell coord Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where toPathPiece = \case - MassInputAddDimension dim -> "addField--" <> tshow dim - MassInputDeleteCell (toPathPiece -> coord) -> "delCell--" <> coord MassInputCell (toPathPiece -> coord) name -> coord <> "__" <> name - fromPathPiece t = addDimension <|> deleteCell <|> cell - where - addDimension = do - dim <- Text.stripPrefix "addField--" t >>= readMay - return $ MassInputAddDimension dim - deleteCell = do - coord <- Text.stripPrefix "delCell--" t >>= fromPathPiece - return $ MassInputDeleteCell coord - cell = do - (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t - coord <- fromPathPiece coordT - return $ MassInputCell coord name + fromPathPiece t = do + (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t + coord <- fromPathPiece coordT + return $ MassInputCell coord name -massInput :: forall handler cellData cellResult liveliness submit p. +massInput :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , Button UniWorX submit, Finite submit ) => ( Natural -- ^ Zero-based dimension index -> liveliness -- ^ Currently live positions @@ -111,7 +101,6 @@ massInput :: forall handler cellData cellResult liveliness submit p. -> (Markup -> MForm handler (FormResult cellResult, Widget)) ) -- ^ Cell-Widget -> FieldSettings UniWorX - -> p submit -> MForm handler (FormResult (Map (BoxCoord liveliness) cellResult), FieldView UniWorX) -massInput mkAddWidget mkCellWidget FieldSettings{..} _ = do +massInput mkAddWidget mkCellWidget FieldSettings{..} = do error "massInput: not implemented" diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 1f1220787..dbb01adf1 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -61,6 +61,8 @@ import Database.Esqueleto.Instances as Import () import Database.Persist.Sql.Instances as Import () import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) +import Numeric.Natural.Instances as Import () + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Numeric/Natural/Instances.hs b/src/Numeric/Natural/Instances.hs new file mode 100644 index 000000000..cb986f770 --- /dev/null +++ b/src/Numeric/Natural/Instances.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Numeric.Natural.Instances + ( + ) where + +import ClassyPrelude +import Numeric.Natural +import Web.PathPieces + +instance PathPiece Natural where + toPathPiece = tshow + fromPathPiece = readMay