feat: i18n form

2021-07-08 15:36:47 +02:00 · 2021-07-08 15:36:47 +02:00 · 2d95f353c1
commit 2d95f353c1
parent a9fe7487a6
22 changed files with 366 additions and 109 deletions
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@ -390,6 +390,12 @@ input[type="button"].btn-info:not(.btn-link):hover,
  padding-right: 10px
  max-width: 300px

+  &.table__td--unlimited
+    max-width: unset
+
+  &.table__td--wide
+    max-width: 600px
+
 .table__td--number
  width: min-content
  padding-left: 0
@ -412,6 +418,12 @@ input[type="button"].btn-info:not(.btn-link):hover,
  line-height: 1.4
  vertical-align: top

+  &.table__td--bottom
+    vertical-align: bottom
+
+  &.table__td--middle
+    vertical-align: middle
+
 .table__td--automatic
  font-style: oblique
  color: var(--color-fontsec)
@ -465,6 +477,10 @@ input[type="button"].btn-info:not(.btn-link):hover,
  max-height: 200px
  overflow-y: auto

+  .table__td--unlimited &, .table__td--wide &
+    max-height: unset
+    overflow-y: unset
+
 .table--vertical
  th, .table__th
    background-color: transparent
@ -1675,3 +1691,9 @@ video
  & > video
    object-fit: contain
    flex-grow: 1
+
+.hr
+  height: 1px
+  width: 90%
+  margin: 0.5em auto
+  background-color: var(--color-grey)
--- a/messages/uniworx/utils/handler_form/de-de-formal.msg
+++ b/messages/uniworx/utils/handler_form/de-de-formal.msg
@ -0,0 +1,3 @@
+I18nFormNoTranslations: (Noch) keine Übersetzungen
+I18nFormLanguageAlreadyExists lang@Lang: Die Sprache „#{lang}“ wurde bereits hinzugefügt.
+I18nFormLanguage: Sprache
--- a/messages/uniworx/utils/handler_form/en-eu.msg
+++ b/messages/uniworx/utils/handler_form/en-eu.msg
@ -0,0 +1,3 @@
+I18nFormLanguageAlreadyExists lang: Language “#{lang}” was already added.
+I18nFormLanguage: Language
+I18nFormNoTranslations: No translations (yet)
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@ -232,17 +232,19 @@ instance RenderMessage UniWorX Load where
    Load { byTutorial = Just True , byProportion = p } -> MsgCorByProportionIncludingTutorial p
    Load { byTutorial = Just False, byProportion = p } -> MsgCorByProportionExcludingTutorial p

-newtype MsgLanguage = MsgLanguage Lang
+data MsgLanguage = MsgLanguage { unMsgLanguage :: Lang } | MsgLanguageEndonym { unMsgLanguage :: Lang }
  deriving stock (Eq, Ord, Show, Read)
 instance RenderMessage UniWorX MsgLanguage where
-  renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
+  renderMessage foundation ls msg@(unMsgLanguage -> lang@(map mk . Text.splitOn "-" -> lang'))
    | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
    | ("de" : _)        <- lang' = mr MsgGerman
    | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
    | ("en" : _)        <- lang' = mr MsgEnglish
    | otherwise = lang
    where
-      mr = renderMessage foundation $ lang : filter (/= lang) ls
+      mr = renderMessage foundation $ case msg of
+        MsgLanguageEndonym _ -> lang : filter (/= lang) ls
+        MsgLanguage _ -> ls

 appLanguagesOpts :: ( MonadHandler m
                    , RenderMessage (HandlerSite m) MsgLanguage
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@ -619,7 +619,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
      activeLang <- selectLanguage appLanguages

      let navChildren = flip map (toList appLanguages) $ \lang -> NavLink
-            { navLabel       = MsgLanguage lang
+            { navLabel       = MsgLanguageEndonym lang
            , navRoute       = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
            , navAccess'     = NavAccessTrue
            , navType        = NavTypeButton
--- a/src/Handler/Admin/Test.hs
+++ b/src/Handler/Admin/Test.hs
@ -149,15 +149,16 @@ postAdminTestR = do
    -- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
    mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
              -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
+              -> ListLength -- ^ Previous shape of massinput
              -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
              -> FieldView UniWorX -- ^ Submit-Button for this add-widget
              -> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
-    mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
+    mkAddForm 0 0 liveliness nudge submitBtn = guardOn (allowAdd 0 0 liveliness) $ \csrf -> do
      (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
      let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
          addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
      return (addRes'', toWidget csrf >> fvWidget addView >> fvWidget submitBtn)
-    mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
+    mkAddForm _pos _dim _ _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"

    -- | Make a single massInput-Cell
    --
@ -184,8 +185,9 @@ postAdminTestR = do

  -- The actual call to @massInput@ is comparatively simple:

-  ((miResult, fvWidget -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
+  ((miResult, fvWidget -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing

+  ((i18nResult, fvWidget -> i18nWidget), i18nEnc) <- runFormPost . identifyForm ("i18n-stored-markup" :: Text) $ i18nField htmlField True (\_ -> Nothing) ("i18n-stored-markup" :: Text) "" True Nothing

  testDownloadWidget <- testDownload

@ -228,6 +230,29 @@ postAdminTestR = do
          <p style="white-space:pre-wrap; font-family:var(--font-monospace);">
            #{tshow res}
    |]
+      
+    i18nIdent <- newIdent
+    let i18nForm' = wrapForm i18nWidget FormSettings
+          { formMethod   = POST
+          , formAction   = Just . SomeRoute $ AdminTestR :#: i18nIdent
+          , formEncoding = i18nEnc
+          , formAttrs    = []
+          , formSubmit   = FormSubmit
+          , formAnchor   = Just i18nIdent
+          }
+    [whamlet|
+      <h2>I18n-Form
+      ^{i18nForm'}
+      $case i18nResult
+        $of FormMissing
+        $of FormFailure errs
+          <ul>
+            $forall err <- errs
+              <li>#{err}
+        $of FormSuccess res
+          <pre .json>
+            #{toYAML res}
+    |]

    [whamlet|
       <section>
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@ -136,8 +136,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
              -> return (termsSetField [cfTerm cform], [cfTerm cform])
      _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms

-    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
-        miAdd _ _ nudge btn = Just $ \csrf -> do
+    let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+        miAdd _ _ _ nudge btn = Just $ \csrf -> do
          (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
          let addRes'' = addRes <&> \newDat oldDat -> if
                | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
@ -165,9 +165,6 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
                 -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
        miDelete = miDeleteList

-        miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
-        miAllowAdd _ _ _ = True
-
        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
        miAddEmpty _ _ _ = Set.empty

--- a/src/Handler/Sheet/Form.hs
+++ b/src/Handler/Sheet/Form.hs
@ -210,10 +210,11 @@ correctorForm loads' = wFormToAForm $ do

    miAdd :: ListPosition
          -> Natural
+          -> ListLength
          -> (Text -> Text)
          -> FieldView UniWorX
          -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
-    miAdd _ _ nudge submitView = Just $ \csrf -> do
+    miAdd _ _ _ nudge submitView = Just $ \csrf -> do
      (addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgSheetCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
      let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
            | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
@ -254,12 +255,6 @@ correctorForm loads' = wFormToAForm $ do
             -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
    miDelete = miDeleteList

-    miAllowAdd :: ListPosition
-               -> Natural
-               -> ListLength
-               -> Bool
-    miAllowAdd _ _ _ = True
-
    miAddEmpty :: ListPosition
               -> Natural
               -> ListLength
--- a/src/Handler/Submission/Helper.hs
+++ b/src/Handler/Submission/Helper.hs
@ -154,10 +154,11 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
        let
          miAdd :: ListPosition
                -> Natural
+                -> ListLength
                -> (Text -> Text)
                -> FieldView UniWorX
                -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
-          miAdd _ _ nudge btn = Just $ \csrf -> do
+          miAdd dim pos liveliness nudge btn = guardOn (miAllowAdd dim pos liveliness) $ \csrf -> do
            MsgRenderer mr <- getMsgRenderer
            (addRes, addView) <- mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
            let addRes' = addRes <&> \newData oldData -> if
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@ -146,12 +146,12 @@ commR CommunicationRoute{..} =  do
  let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
        where
-          miAdd (BoundedPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
+          miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
            (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
            let
              addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
            return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
-          miAdd _ _ _ _ = Nothing
+          miAdd _ _ _ _ _ = Nothing
          miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
            return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.Utils.Form
  ( module Handler.Utils.Form
  , module Handler.Utils.Form.MassInput
@ -60,7 +62,7 @@ import Data.Aeson.Text (encodeToLazyText)
 import qualified Text.Email.Validate as Email

 import Data.Text.Lens (unpacked)
-import Text.Blaze (toMarkup)
+import Text.Blaze (toMarkup, Markup)

 import Handler.Utils.Form.MassInput

@ -73,6 +75,8 @@ import qualified Data.Text.Lazy.Builder as Builder
 import qualified Data.Yaml as Yaml

 import Control.Monad.Catch.Pure (runCatch)
+
+import qualified Data.List.NonEmpty as NonEmpty
  
 {-# ANN module ("HLint: ignore Use const" :: String) #-}

@ -696,7 +700,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
                 , $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
                 )

-        miAdd _ _ nudge submitView = Just $ \csrf -> do
+        miAdd _ _ _ nudge submitView = Just $ \csrf -> do
          (formRes, formWidget) <- sFileForm nudge Nothing csrf
          let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
              addRes' = formRes <&> \fileRes oldRess ->
@ -707,7 +711,6 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
          sFileForm nudge (Just initFile) csrf
        miDelete :: MassInputDelete ListLength
        miDelete = miDeleteList
-        miAllowAdd _ _ _ = True
        miAddEmpty _ _ _ = Set.empty
        miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
@ -2345,3 +2348,152 @@ roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap clas
              <$> roomRefLink'
              <*> roomRefInstructions'
        return $ Just <$> res
+
+newtype I18nLangs = I18nLangs { unI18nLangs :: Set I18nLang }
+  deriving newtype (ToJSON, FromJSON, MonoFoldable, Semigroup, Monoid, Lattice, BoundedJoinSemiLattice)
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+type instance Element I18nLangs = I18nLang
+
+newtype I18nLang = I18nLang { unI18nLang :: Lang }
+  deriving newtype (PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+  deriving (Eq, Generic, Typeable, Read, Show)
+
+instance Ord I18nLang where
+  compare = mconcat
+    [ comparing $ NTop . flip elemIndex (toList appLanguages) . unI18nLang
+    , comparing $ T.splitOn "-" . unI18nLang
+    ]
+
+makeWrapped ''I18nLangs
+makeWrapped ''I18nLang
+
+instance IsBoxCoord I18nLang where
+  boxDimensions = [BoxDimension _Wrapped]
+  boxOrigin = _Wrapped # NonEmpty.head appLanguages
+
+instance Liveliness I18nLangs where
+  type BoxCoord I18nLangs = I18nLang
+  liveCoords = from _Wrapped
+
+i18nLangMap :: Prism' (Map I18nLang a) (I18n a)
+i18nLangMap = prism' toLangMap fromLangMap
+  where
+    -- ugh.
+    toLangMap I18n{..} = Map.mapKeys I18nLang $ if
+      | Just fLang <- i18nFallbackLang
+        -> Map.insert fLang i18nFallback i18nTranslations
+      | missing : _ <- sortOn langSortProj . toList $ setOf folded appLanguages `Set.difference` Map.keysSet i18nTranslations
+        -> Map.insert missing i18nFallback i18nTranslations
+      | otherwise
+        -> Map.insert (NonEmpty.head appLanguages) i18nFallback i18nTranslations
+    fromLangMap lMap = do
+      (Just -> i18nFallbackLang, i18nFallback) : i18nTranslations' <- return
+        $ Map.toList lMap
+        & over (traverse . _1) (view _Wrapped)
+        & sortOn (views _1 langSortProj)
+      let i18nTranslations = Map.fromList i18nTranslations'
+      return I18n{..}
+
+    langSortProj = NTop . flip elemIndex (toList appLanguages)
+
+i18nForm :: forall a ident handler.
+            ( PathPiece ident
+            , MonadHandler handler, HandlerSite handler ~ UniWorX
+            , MonadThrow handler
+            )
+         => ((Text -> Text) -> Maybe a -> (Markup -> MForm handler (FormResult a, Widget)))
+         -> Bool -- ^ Allow only languages from `appLanguages`?
+         -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+         -> ident
+         -> FieldSettings UniWorX
+         -> Bool
+         -> Maybe (I18n a)
+         -> (Markup -> MForm handler (FormResult (I18n a), FieldView UniWorX))
+i18nForm strForm onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' csrf'
+  = fmap (over _1 massageFormResult) . ($ csrf') . massInput MassInput{..} fSettings fRequired $ fmap ((), ) . review i18nLangMap <$> mPrev'
+  where
+    massageFormResult :: FormResult (Map I18nLang ((), a)) -> FormResult (I18n a)
+    massageFormResult = \case
+      FormSuccess xs
+        | Just xs' <- preview i18nLangMap $ map (view _2) xs
+          -> FormSuccess xs'
+        | otherwise
+          -> FormMissing
+      FormFailure errs -> FormFailure errs
+      FormMissing -> FormMissing
+
+    miAdd :: I18nLang -> Natural -> I18nLangs
+          -> (Text -> Text) -> FieldView UniWorX
+          -> Maybe (Markup -> MForm handler (FormResult (Map I18nLang () -> FormResult (Map I18nLang ())), Widget))
+    miAdd _pos _dimIx liveliness nudge submitBtn = guardOn (not $ onlyAppLanguages && null (missingLangs liveliness)) $ \csrf -> do
+        let langField' :: Field Handler Lang
+            langField'
+              | onlyAppLanguages = selectField langOpts
+              | otherwise = textField
+                          & addDatalist langOpts
+                          & cfStrip
+                          & checkBool langCheck MsgInvalidLangFormat
+              where
+                langOpts = do
+                  MsgRenderer mr <- getMsgRenderer
+                  let mkOption l = Option
+                        { optionDisplay = mr $ MsgLanguage l
+                        , optionInternalValue = l
+                        , optionExternalValue = l
+                        }
+                  return OptionList
+                    { olOptions = map (views _Wrapped mkOption) $ missingLangs liveliness
+                    , olReadExternal = if
+                        | onlyAppLanguages -> assertM' (`elem` toList appLanguages)
+                        | otherwise -> Just
+                    }
+                langCheck (T.splitOn "-" -> lParts)
+                  = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
+                 && not (null lParts)
+
+        (langRes, langView) <- mpopt (hoistField liftHandler langField' & isoField _Unwrapped) (def & addName (nudge "lang")) $ missingLangs liveliness ^? _head
+
+        MsgRenderer mr <- getMsgRenderer
+        let res = langRes <&> \newLang oldLangs -> if
+              | newLang `Map.member` oldLangs -> FormFailure . pure . mr . MsgI18nFormLanguageAlreadyExists $ newLang ^. _Wrapped
+              | otherwise -> pure $ Map.singleton newLang ()
+
+        return (res, $(widgetFile "widgets/i18n-form/add"))
+      where
+        missingLangs liveliness' = Set.toAscList $ setOf (folded . re _Wrapped) appLanguages `Set.difference` view _Wrapped liveliness'
+
+    miCell :: I18nLang -> () -> Maybe a
+           -> (Text -> Text)
+           -> (Markup -> MForm handler (FormResult a, Widget))
+    miCell _ _ mPrev nudge csrf = do
+      (strRes, strView) <- strForm nudge mPrev csrf
+      return (strRes, $(widgetFile "widgets/i18n-form/cell"))
+
+    miDelete :: Map I18nLang ()
+             -> I18nLang
+             -> MaybeT (MForm handler) (Map I18nLang I18nLang)
+    miDelete liveliness' coord = return . Map.delete coord . Map.fromSet id $ Map.keysSet liveliness'
+
+    miAddEmpty :: I18nLang
+               -> Natural
+               -> I18nLangs
+               -> Set I18nLang
+    miAddEmpty _ _ _ = Set.empty
+
+    miLayout :: MassInputLayout I18nLangs () a
+    miLayout (I18nLangs langs) _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/i18n-form/layout")
+
+i18nField :: forall a ident handler.
+             ( PathPiece ident
+             , MonadHandler handler, HandlerSite handler ~ UniWorX
+             , MonadThrow handler
+             )
+          => Field handler a
+          -> Bool -- ^ Allow only languages from `appLanguages`?
+          -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+          -> ident
+          -> FieldSettings UniWorX
+          -> Bool
+          -> Maybe (I18n a)
+          -> (Markup -> MForm handler (FormResult (I18n a), FieldView UniWorX))
+i18nField strField = i18nForm $ \nudge mPrev csrf -> over _2 ((toWidget csrf <>) . fvWidget) <$> mpreq strField (def & addName (nudge "string")) mPrev
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@ -35,6 +35,9 @@ import Text.Hamlet (hamletFile)

 import Algebra.Lattice.Ordered (Ordered(..))

+import Control.Monad.Trans.RWS.Lazy (evalRWST)
+import qualified Control.Monad.State.Class as State
+
 {-# ANN module ("HLint: ignore Use const" :: String) #-}


@ -244,10 +247,11 @@ data MassInputException = MassInputInvalidShape
 instance Exception MassInputException

 data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => MassInput
-  { miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
-          -> Natural -- Zero-based dimension index @dimIx@
-          -> (Text -> Text) -- Nudge deterministic field ids
-          -> FieldView UniWorX -- Submit button
+  { miAdd :: BoxCoord liveliness -- ^ Position (dimensions after @dimIx@ are zero)
+          -> Natural -- ^ Zero-based dimension index @dimIx@
+          -> liveliness -- ^ Previous liveliness
+          -> (Text -> Text) -- ^ Nudge deterministic field ids
+          -> FieldView UniWorX -- ^ Submit button
          -> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
  , miCell :: BoxCoord liveliness -- Position
           -> cellData -- @cellData@ from @miAdd@
@ -257,10 +261,6 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i =>
  , miDelete :: Map (BoxCoord liveliness) cellData
             -> BoxCoord liveliness
             -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
-  , miAllowAdd :: BoxCoord liveliness
-               -> Natural
-               -> liveliness
-               -> Bool -- ^ Decide whether an addition-operation should be permitted
  , miAddEmpty :: BoxCoord liveliness
               -> Natural
               -> liveliness
@ -315,74 +315,88 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
    | otherwise -> throwM MassInputInvalidShape
  sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness

-  let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
-      addForm = addForm' boxOrigin [] . zip [0..]
-        where
-          addForm' _ _ [] = return Map.empty
-          addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
-            let nudgeAddWidgetName :: Text -> Text
-                nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
-            (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
-            let btnRes = do
-                  Just x <- btnRes'
-                  return x
-                wBtnRes res = do
-                  guard $ isn't _FormMissing btnRes
-                  res
-                miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
-            addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
-            addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
-            let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
-            case remDims of
-              [] -> return dimRes'
-              ((_, BoxDimension dim) : _) -> do
-                let miCoords
-                      = Set.union (miAddEmpty miCoord dimIx sentLiveliness)
-                      . Set.map (\c -> miCoord & dim .~ (c ^. dim))
-                      . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
-                      $ review liveCoords sentLiveliness
-                dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
-                return $ dimRes' `Map.union` fold dimRess
+  let runTwice :: (Maybe res -> MForm handler res) -> MForm handler res
+      runTwice act = do
+        r <- ask
+        s <- State.get
+        res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s 
+        local (_1 .~ Nothing) . act $ Just res1
+      replaceWithFirst :: forall k x y. Ord k => Maybe (Map k (x, y)) -> Map k (x, y) -> Map k (x, y)
+      replaceWithFirst Nothing xs = xs
+      replaceWithFirst (Just f) s = Map.unionWith (\(f1, _f2) (_s1, s2) -> (f1, s2)) f s
+ 
+  (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged) <- runTwice $ \mPrev -> do
+    let sentLiveliness' = maybe sentLiveliness (view _2) mPrev

-  addResults <- addForm boxDimensions
-  let
-    addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
-    addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
-        FormSuccess (Just mkResult)
-          | miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
+    let addForm :: MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
+        addForm = addForm' boxOrigin [] $ zip [0..] boxDimensions
+          where
+            addForm' _ _ [] = return Map.empty
+            addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
+              let nudgeAddWidgetName :: Text -> Text
+                  nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
+              (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
+              let btnRes = do
+                    Just x <- btnRes'
+                    return x
+                  wBtnRes res = do
+                    guard $ isn't _FormMissing btnRes
+                    res
+                  miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx sentLiveliness' nudgeAddWidgetName btnView
+              addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
+              addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
+              let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
+              case remDims of
+                [] -> return dimRes'
+                ((_, BoxDimension dim) : _) -> do
+                  let miCoords
+                        = Set.union (miAddEmpty miCoord dimIx sentLiveliness')
+                        . Set.map (\c -> miCoord & dim .~ (c ^. dim))
+                        . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
+                        $ review liveCoords sentLiveliness'
+                  dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
+                  return $ dimRes' `Map.union` fold dimRess
+
+    addResults <- replaceWithFirst (view _4 <$> mPrev) <$> addForm
+    let
+      addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
+      addResults' = fmap (view _1) addResults <&> \case
+        FormSuccess (Just mkShape) -> Just <$> mkShape sentShape'
        other -> Nothing <$ other
-  let addShape
-        | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
-        = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
-        | otherwise = Nothing
+    let addShape
+          | [FormSuccess (Just mkResult)] <- Map.elems . Map.filter (is $ _FormSuccess . _Just) $ view _1 <$> addResults
+          = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape') sentShape'
+          | otherwise = Nothing

-  addedShape <- if
-    | Just s <- addShape -> return s
-    | otherwise -> return sentShape'
+    addedShape <- if
+      | Just s <- addShape -> return s
+      | otherwise -> return sentShape'

-  let
-    delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
-    delForm miCoord = do
-      (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
-      shapeUpdate <- miDelete addedShape miCoord
-      guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
-      return (shapeUpdate <$ assertM (is _Just) delRes, delView)
+    let
+      delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
+      delForm miCoord = do
+        (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
+        shapeUpdate <- miDelete addedShape miCoord
+        guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
+        return (shapeUpdate <$ assertM (is _Just) delRes, delView)

-  delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
-  let
-    delShapeUpdate
-        | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
-        | otherwise = Nothing
-    delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
+    delResults <- fmap (replaceWithFirst (view _6 <$> mPrev) . Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
+    let
+      delShapeUpdate
+          | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
+          | otherwise = Nothing
+      delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate


-  let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
+    let shapeChanged = Fold.any (hasn't $ _1 . _FormMissing) addResults || Fold.any (has $ _1 . _FormSuccess) delResults

-  shape <- if
-    | Just s <- addShape -> return s
-    | Just s <- delShape -> return s
-    | otherwise          -> return sentShape'
-  liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+    shape <- if
+      | Just s <- addShape -> return s
+      | Just s <- delShape -> return s
+      | otherwise          -> return sentShape'
+    liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+
+    return (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged)

  shapeId <- newIdent
  let shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
@ -424,7 +438,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
          (fmap (view _1 &&& view (_2 . _1)) cellResults)
          (fmap (view $ _2 . _2) cellResults)
          (fmap (view _2) delResults)
-          (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
+          (Map.mapMaybe (view _2) addResults)

  MsgRenderer mr <- getMsgRenderer

@ -489,12 +503,11 @@ massInputList :: forall handler cellResult ident msg.
              -> Maybe [cellResult]
              -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
 massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
-  MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
+  MassInput { miAdd = \_ _ _ _ submitBtn -> Just $ \csrf ->
                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
            , miCell = \pos () iRes nudge csrf ->
                over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
            , miDelete = miDeleteList
-            , miAllowAdd = \_ _ _ -> True
            , miAddEmpty = \_ _ _ -> Set.empty
            , miButtonAction
            , miLayout = listMiLayout
@ -541,10 +554,10 @@ massInputAccum :: forall handler cellData ident.
 massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
  = over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
  where
-    miAdd :: ListPosition -> Natural
+    miAdd :: ListPosition -> Natural -> ListLength
          -> (Text -> Text) -> FieldView UniWorX
          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
-    miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
+    miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)

    doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
    doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@ -559,8 +572,6 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
    miDelete :: MassInputDelete ListLength
    miDelete = miDeleteList

-    miAllowAdd _ _ _ = True
-
    miAddEmpty _ _ _ = Set.empty

 massInputAccumA :: forall handler cellData ident.
@ -619,10 +630,10 @@ massInputAccumEdit :: forall handler cellData ident.
 massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
  = over (_1 . mapped) (map snd . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (\x -> (x, x)) <$> mPrev) csrf
  where
-    miAdd :: ListPosition -> Natural
+    miAdd :: ListPosition -> Natural -> ListLength
          -> (Text -> Text) -> FieldView UniWorX
          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
-    miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
+    miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)

    doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
    doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@ -637,8 +648,6 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
    miDelete :: MassInputDelete ListLength
    miDelete = miDeleteList

-    miAllowAdd _ _ _ = True
-
    miAddEmpty _ _ _ = Set.empty

 massInputAccumEditA :: forall handler cellData ident.
--- a/src/Handler/Utils/Workflow/EdgeForm.hs
+++ b/src/Handler/Utils/Workflow/EdgeForm.hs
@ -527,10 +527,11 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec

                miAdd :: ListPosition
                      -> Natural
+                      -> ListLength
                      -> (Text -> Text)
                      -> FieldView UniWorX
                      -> Maybe (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))), Widget))
-                miAdd _pos _dim nudge submitView = Just $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
+                miAdd pos dim liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
                  where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
                                 -> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
                                 -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
--- a/src/Model/Types/Markup.hs
+++ b/src/Model/Types/Markup.hs
@ -3,6 +3,7 @@ module Model.Types.Markup
  , StoredMarkup(..)
  , htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup
  , esqueletoMarkupOutput
+  , I18nStoredMarkup
  ) where

 import Import.NoModel
@ -133,3 +134,5 @@ instance PersistField StoredMarkup where
  toPersistValue = PersistLiteralEscaped . LBS.toStrict . Aeson.encode
 instance PersistFieldSql StoredMarkup where
  sqlType _ = SqlOther "jsonb"
+
+type I18nStoredMarkup = I18n StoredMarkup
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -613,6 +613,9 @@ mapFromSetM = (sequenceA .) . Map.fromSet
 mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v)
 mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m)

+_MapUnit :: Iso' (Map k ()) (Set k)
+_MapUnit = iso Map.keysSet $ Map.fromSet (const ())
+
 ---------------
 -- Functions --
 ---------------
--- a/templates/widgets/i18n-form/add.hamlet
+++ b/templates/widgets/i18n-form/add.hamlet
@ -0,0 +1,12 @@
+$newline never
+<td .table__td .table__td--middle>
+  <div .table__td-content>
+    <label for=#{fvId langView} .form-group-label>
+      _{MsgI18nFormLanguage}
+<td .table__td .table__td--unlimited .table__td--middle>
+  <div .table__td-content>
+    #{csrf}
+    ^{fvWidget langView}
+<td .table__td .table__td--middle>
+  <div .table__td-content>
+    ^{fvWidget submitBtn}
--- a/templates/widgets/i18n-form/cell.hamlet
+++ b/templates/widgets/i18n-form/cell.hamlet
@ -0,0 +1,4 @@
+$newline never
+<td .table__td .table__td--wide>
+  <div .table__td-content>
+    ^{strView}
--- a/templates/widgets/i18n-form/layout.hamlet
+++ b/templates/widgets/i18n-form/layout.hamlet
@ -0,0 +1,25 @@
+$newline never
+<table .table .table--narrow .table--condensed>
+  <tbody>
+    $if null langs
+      <tr>
+        <td .table__td colspan="3">
+          <div .table__td-content .explanation>
+            _{MsgI18nFormNoTranslations}
+    $else
+      $forall coord@(I18nLang lang) <- langs
+        <tr .massinput__cell>
+          <td .table__td>
+            <div .table__td-content .form-group-label>
+              _{MsgLanguage lang}
+          ^{cellWdgts ! coord}
+          <td .table__td .table__td--middle>
+            <div .table__td-content>
+              ^{fvWidget (delButtons ! coord)}
+  $maybe addWdgt <- Map.lookup (0, boxOrigin) addWdgts
+    <tfoot>
+      <tr>
+        <td colspan="3">
+          <div .hr>
+      <tr .massinput__cell.massinput__cell--add>
+        ^{addWdgt}
--- a/templates/widgets/occurrence/form/except-add.hamlet
+++ b/templates/widgets/occurrence/form/except-add.hamlet
@ -1,5 +1,5 @@
 $newline never
 <td colspan=2>
  ^{addWidget}
-<td style="vertical-align: bottom">
+<td .table__td--bottom>
  ^{fvWidget submitView}
--- a/templates/widgets/occurrence/form/except-layout.hamlet
+++ b/templates/widgets/occurrence/form/except-layout.hamlet
@ -11,7 +11,7 @@ $newline never
        <td colspan=3 .note>
          _{MsgOccurrenceNoneExceptions}
    <td colspan=3>
-      <div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">
+      <div .hr>
  <tfoot>
    <tr .massinput__cell.massinput__cell--add>
      ^{addWdgts ! (0, 0)}
--- a/templates/widgets/occurrence/form/scheduled-add.hamlet
+++ b/templates/widgets/occurrence/form/scheduled-add.hamlet
@ -1,5 +1,5 @@
 $newline never
 <td colspan=2>
  ^{addWidget}
-<td style="vertical-align: bottom">
+<td .table__td--bottom>
  ^{fvWidget submitView}
--- a/templates/widgets/occurrence/form/scheduled-layout.hamlet
+++ b/templates/widgets/occurrence/form/scheduled-layout.hamlet
@ -11,7 +11,7 @@ $newline never
        <td colspan=3 .note>
          _{MsgOccurrenceNoneScheduled}
    <td colspan=3>
-      <div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">
+      <div .hr>
  <tfoot>
    <tr .massinput__cell.massinput__cell--add>
      ^{addWdgts ! (0, 0)}