feat(course-communication): one recipient group per tutorial
Fixes #428
This commit is contained in:
Gregor Kleen
parent
4fb6762b89
commit
99f23f2558
@ -1445,7 +1445,7 @@ RGCourseParticipants: Kursteilnehmer
|
||||
RGCourseLecturers: Kursverwalter
|
||||
RGCourseCorrectors: Korrektoren
|
||||
RGCourseTutors: Tutoren
|
||||
RGTutorialParticipants: Tutorium-Teilnehmer
|
||||
RGTutorialParticipants tutn@TutorialName: Tutorium-Teilnehmer (#{tutn})
|
||||
|
||||
MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
|
||||
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
|
||||
|
||||
@ -1445,7 +1445,7 @@ RGCourseParticipants: Course participants
|
||||
RGCourseLecturers: Course administrators
|
||||
RGCourseCorrectors: Course correctors
|
||||
RGCourseTutors: Course tutors
|
||||
RGTutorialParticipants: Tutorial participants
|
||||
RGTutorialParticipants tutn: Tutorial participants (#{tutn})
|
||||
|
||||
MultiSelectFieldTip: Multiple selections are possible (Shift or Ctrl)
|
||||
MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
|
||||
|
||||
@ -16,21 +16,28 @@ import qualified Data.Map as Map
|
||||
getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTCommR = postTCommR
|
||||
postTCommR tid ssh csh tutn = do
|
||||
(cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn
|
||||
((cid, tutid), usertuts) <- runDB $ do
|
||||
tutData@(cid, _) <- fetchCourseIdTutorialId tid ssh csh tutn
|
||||
tuts <- selectList [TutorialCourse ==. cid] []
|
||||
usertuts <- forMaybeM tuts $ \(Entity tutid Tutorial{..}) -> do
|
||||
cID <- encrypt tutid
|
||||
guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR
|
||||
return ( RGTutorialParticipants cID
|
||||
, E.from $ \(user `E.InnerJoin` participant) -> do
|
||||
E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
return user
|
||||
)
|
||||
return (tutData, usertuts)
|
||||
|
||||
|
||||
commR CommunicationRoute
|
||||
{ crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
|
||||
, crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
|
||||
, crJobs = crJobsCourseCommunication cid
|
||||
, crTestJobs = crTestJobsCourseCommunication cid
|
||||
, crRecipients = Map.fromList
|
||||
[ ( RGTutorialParticipants
|
||||
, E.from $ \(user `E.InnerJoin` participant) -> do
|
||||
E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
return user
|
||||
)
|
||||
, ( RGCourseLecturers
|
||||
, crRecipients = Map.fromList $
|
||||
[ ( RGCourseLecturers
|
||||
, E.from $ \(user `E.InnerJoin` lecturer) -> do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
|
||||
@ -52,7 +59,7 @@ postTCommR tid ssh csh tutn = do
|
||||
E.&&. tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
return user
|
||||
)
|
||||
]
|
||||
] ++ usertuts
|
||||
, crRecipientAuth = Just $ \uid -> do
|
||||
isTutorialUser <- E.selectExists . E.from $ \tutorialUser ->
|
||||
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
|
||||
|
||||
@ -23,17 +23,14 @@ import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
|
||||
| RGTutorialParticipants
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
| RGTutorialParticipants CryptoUUIDTutorial
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe RecipientGroup
|
||||
instance Finite RecipientGroup
|
||||
nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''RecipientGroup id
|
||||
instance LowerBounded RecipientGroup where
|
||||
minBound' = RGCourseParticipants
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''RecipientGroup
|
||||
derivePathPiece ''RecipientGroup (camelToPathPiece' 1) "--"
|
||||
pathPieceJSON ''RecipientGroup
|
||||
|
||||
|
||||
data RecipientCategory
|
||||
@ -41,19 +38,8 @@ data RecipientCategory
|
||||
| RecipientCustom
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveFinite ''RecipientCategory
|
||||
finiteEnum ''RecipientCategory
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, unwrapUnaryRecords = True
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''RecipientCategory
|
||||
|
||||
instance ToJSONKey RecipientCategory where
|
||||
toJSONKey = toJSONKeyText toPathPiece
|
||||
instance FromJSONKey RecipientCategory where
|
||||
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece
|
||||
instance LowerBounded RecipientCategory where
|
||||
minBound' = RecipientGroup minBound'
|
||||
|
||||
instance PathPiece RecipientCategory where
|
||||
toPathPiece RecipientCustom = "custom"
|
||||
@ -62,13 +48,8 @@ instance PathPiece RecipientCategory where
|
||||
fromPathPiece "custom" = Just RecipientCustom
|
||||
fromPathPiece t = RecipientGroup <$> fromPathPiece t
|
||||
|
||||
instance RenderMessage UniWorX RecipientCategory where
|
||||
renderMessage foundation ls = \case
|
||||
RecipientCustom -> renderMessage' MsgRecipientCustom
|
||||
RecipientGroup g -> renderMessage' g
|
||||
where
|
||||
renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
||||
renderMessage' = renderMessage foundation ls
|
||||
pathPieceJSON ''RecipientCategory
|
||||
pathPieceJSONKey ''RecipientCategory
|
||||
|
||||
data CommunicationButton
|
||||
= BtnCommunicationSend
|
||||
@ -147,13 +128,13 @@ commR CommunicationRoute{..} = do
|
||||
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (Map.elems suggestedRecipients) ++ chosenRecipients
|
||||
|
||||
let chosenRecipients' = Map.fromList $
|
||||
[ ( (EnumPosition $ RecipientGroup g, pos)
|
||||
[ ( (BoundedPosition $ RecipientGroup g, pos)
|
||||
, (Right recp, recp `elem` map entityKey chosenRecipients)
|
||||
)
|
||||
| (g, recps) <- Map.toList suggestedRecipients
|
||||
, (pos, recp) <- zip [0..] $ map entityKey recps
|
||||
] ++
|
||||
[ ( (EnumPosition RecipientCustom, pos)
|
||||
[ ( (BoundedPosition RecipientCustom, pos)
|
||||
, (Right recp, True)
|
||||
)
|
||||
| (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients)
|
||||
@ -163,10 +144,10 @@ commR CommunicationRoute{..} = do
|
||||
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
|
||||
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
|
||||
where
|
||||
miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
|
||||
miAdd (BoundedPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
|
||||
let
|
||||
addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (EnumPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
|
||||
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
|
||||
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
|
||||
@ -179,31 +160,36 @@ commR CommunicationRoute{..} = do
|
||||
| otherwise
|
||||
-> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
|
||||
return (tickRes, $(widgetFile "widgets/communication/recipientName"))
|
||||
miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
|
||||
miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True
|
||||
miAllowAdd _ _ _ = False
|
||||
miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0)
|
||||
miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0)
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
|
||||
miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
|
||||
-> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
|
||||
-> Map (EnumPosition RecipientCategory, ListPosition) Widget
|
||||
-> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
|
||||
-> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
|
||||
miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength
|
||||
-> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool)
|
||||
-> Map (BoundedPosition RecipientCategory, ListPosition) Widget
|
||||
-> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX)
|
||||
-> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget
|
||||
-> Widget
|
||||
miLayout liveliness cState cellWdgts _delButtons addWdgts = do
|
||||
checkedIdentBase <- newIdent
|
||||
let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
|
||||
let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
|
||||
checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
|
||||
hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
|
||||
categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
|
||||
hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts
|
||||
categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness
|
||||
rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget
|
||||
rgTutorialParticipantsCaption cID = do
|
||||
tutId <- decrypt cID
|
||||
Tutorial{..} <- liftHandler . runDBRead $ get404 tutId
|
||||
i18n $ MsgRGTutorialParticipants tutorialName
|
||||
$(widgetFile "widgets/communication/recipientLayout")
|
||||
miDelete :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
|
||||
-- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
|
||||
miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition))
|
||||
-- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos
|
||||
miDelete _ _ = mzero
|
||||
miIdent :: Text
|
||||
miIdent = "recipients"
|
||||
postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
|
||||
postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
|
||||
postProcess = Set.fromList . map fst . filter snd . Map.elems
|
||||
|
||||
recipientsListMsg <- messageI Info MsgCommRecipientsList
|
||||
|
||||
@ -13,6 +13,7 @@ module Handler.Utils.Form.MassInput
|
||||
, ListLength(..), ListPosition(..), miDeleteList
|
||||
, EnumLiveliness(..), EnumPosition(..)
|
||||
, MapLiveliness(..)
|
||||
, LowerBounded(..), BoundedLiveliness(..), BoundedPosition(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -81,17 +82,10 @@ instance Liveliness ListLength where
|
||||
|
||||
newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
|
||||
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
||||
deriving newtype (Lattice, BoundedJoinSemiLattice)
|
||||
|
||||
makeWrapped ''EnumLiveliness
|
||||
|
||||
instance Lattice (EnumLiveliness enum) where
|
||||
(EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
|
||||
(EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
|
||||
instance BoundedJoinSemiLattice (EnumLiveliness enum) where
|
||||
bottom = EnumLiveliness IntSet.empty
|
||||
instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
|
||||
top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
|
||||
|
||||
|
||||
newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
|
||||
deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
|
||||
@ -99,11 +93,11 @@ newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
|
||||
|
||||
makeWrapped ''EnumPosition
|
||||
|
||||
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
|
||||
instance (Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
|
||||
boxDimensions = [BoxDimension _Wrapped]
|
||||
boxOrigin = minBound
|
||||
|
||||
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
|
||||
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Ord enum) => Liveliness (EnumLiveliness enum) where
|
||||
type BoxCoord (EnumLiveliness enum) = EnumPosition enum
|
||||
liveCoords = iso fromSet toSet
|
||||
where
|
||||
@ -113,6 +107,28 @@ instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, T
|
||||
fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
|
||||
|
||||
|
||||
class Ord coord => LowerBounded coord where
|
||||
minBound' :: coord
|
||||
|
||||
newtype BoundedLiveliness coord = BoundedLiveliness { unBoundedLiveliness :: Set coord }
|
||||
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
||||
deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)
|
||||
makeWrapped ''BoundedLiveliness
|
||||
|
||||
newtype BoundedPosition coord = BoundedPosition { unBoundedPosition :: coord }
|
||||
deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey, LowerBounded)
|
||||
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
||||
makeWrapped ''BoundedPosition
|
||||
|
||||
instance (LowerBounded coord, PathPiece coord, ToJSON coord, FromJSON coord, ToJSONKey coord, FromJSONKey coord, Ord coord) => IsBoxCoord (BoundedPosition coord) where
|
||||
boxDimensions = [BoxDimension _Wrapped]
|
||||
boxOrigin = minBound'
|
||||
|
||||
instance (LowerBounded coord, PathPiece coord, ToJSON coord, FromJSON coord, ToJSONKey coord, FromJSONKey coord, Ord coord) => Liveliness (BoundedLiveliness coord) where
|
||||
type BoxCoord (BoundedLiveliness coord) = BoundedPosition coord
|
||||
liveCoords = iso (Set.mapMonotonic $ view _Wrapped) (Set.mapMonotonic $ view _Unwrapped) . _Unwrapped
|
||||
|
||||
|
||||
newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
|
||||
@ -20,7 +20,7 @@ import qualified Data.Set as Set
|
||||
import Data.List (genericLength, genericIndex)
|
||||
|
||||
|
||||
data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n)
|
||||
data BoxDimension x = forall n. Eq n => BoxDimension (Lens' x n)
|
||||
|
||||
class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where
|
||||
boxDimensions :: [BoxDimension x]
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
module Utils.PathPiece
|
||||
( nullaryToPathPiece', nullaryToPathPiece
|
||||
, nullaryPathPiece', nullaryPathPiece, finitePathPiece
|
||||
, derivePathPiece
|
||||
, splitCamel
|
||||
, camelToPathPiece, camelToPathPiece'
|
||||
, nameToPathPiece, nameToPathPiece'
|
||||
@ -13,6 +14,7 @@ import ClassyPrelude.Yesod
|
||||
|
||||
import Language.Haskell.TH
|
||||
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
|
||||
import Language.Haskell.TH.Datatype
|
||||
import Data.Universe
|
||||
|
||||
import qualified Data.Text as Text
|
||||
@ -85,6 +87,51 @@ finitePathPiece finiteType verbs = do
|
||||
, funD 'fromPathPiece
|
||||
[ clause [] (normalB $ return finExp) [] ]
|
||||
]
|
||||
|
||||
derivePathPiece :: Name -> (Text -> Text) -> Text -> DecsQ
|
||||
derivePathPiece adt mangle joinPP = do
|
||||
let mangle' = TH.lift . mangle . pack . nameBase
|
||||
DatatypeInfo{..} <- reifyDatatype adt
|
||||
mapName <- newName $ "pathPieceConstructorMap" <> nameBase adt
|
||||
let
|
||||
toClause ConstructorInfo{..} = do
|
||||
vars <- mapM (const $ newName "x") constructorFields
|
||||
clause [conP constructorName $ map varP vars] (normalB [e|Text.intercalate joinPP $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) []
|
||||
fromClause = do
|
||||
constrName <- newName "c"
|
||||
argsName <- newName "args"
|
||||
clause [viewP [e|Text.splitOn joinPP|] $ infixP (varP constrName) '(:) (varP argsName)]
|
||||
(normalB [e|HashMap.lookup $(varE constrName) $(varE mapName) >>= ($ $(varE argsName))|])
|
||||
[]
|
||||
finDecs =
|
||||
[ pragInlD mapName NoInline FunLike AllPhases
|
||||
, sigD mapName [t|HashMap Text ([Text] -> Maybe $(conT adt))|]
|
||||
, funD mapName
|
||||
[ clause [] (normalB finClause) [] ]
|
||||
]
|
||||
where finClause = ([e|HashMap.fromList|] `appE`) . listE $ map listItem datatypeCons
|
||||
listItem ConstructorInfo{..} = do
|
||||
vars <- mapM (const $ newName "x") constructorFields
|
||||
tupE [ mangle' constructorName
|
||||
, lamCaseE
|
||||
[ match (listP $ map varP vars)
|
||||
(normalB $ case vars of
|
||||
[] -> [e|Just $(conE constructorName)|]
|
||||
v : vs -> foldl' (\acc v' -> [e|$(acc) <*> fromPathPiece $(varE v')|]) [e|$(conE constructorName) <$> fromPathPiece $(varE v)|] vs
|
||||
)
|
||||
[]
|
||||
, match wildP (normalB [e|Nothing|]) []
|
||||
]
|
||||
]
|
||||
sequence . (finDecs ++ ) . pure $
|
||||
instanceD (cxt []) [t|PathPiece $(conT adt)|]
|
||||
[ funD 'toPathPiece
|
||||
(map toClause datatypeCons)
|
||||
, funD 'fromPathPiece
|
||||
[ fromClause
|
||||
, clause [wildP] (normalB [e|Nothing|]) []
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
splitCamel :: Textual t => t -> [t]
|
||||
|
||||
@ -5,7 +5,19 @@ $if not (null activeCategories)
|
||||
<div .recipient-category>
|
||||
<input type=checkbox id=#{checkedIdent category} .recipient-category__checkbox :elem category checkedCategories:checked>
|
||||
<label .recipient-category__label for=#{checkedIdent category}>
|
||||
_{category}
|
||||
$case category
|
||||
$of RecipientCustom
|
||||
_{MsgRecipientCustom}
|
||||
$of RecipientGroup RGCourseParticipants
|
||||
_{MsgRGCourseParticipants}
|
||||
$of RecipientGroup RGCourseLecturers
|
||||
_{MsgRGCourseLecturers}
|
||||
$of RecipientGroup RGCourseCorrectors
|
||||
_{MsgRGCourseCorrectors}
|
||||
$of RecipientGroup RGCourseTutors
|
||||
_{MsgRGCourseTutors}
|
||||
$of RecipientGroup (RGTutorialParticipants tutid)
|
||||
^{rgTutorialParticipantsCaption tutid}
|
||||
|
||||
$if hasContent category
|
||||
<fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>
|
||||
@ -18,5 +30,5 @@ $if not (null activeCategories)
|
||||
$forall optIx <- categoryIndices category
|
||||
^{cellWdgts ! optIx}
|
||||
|
||||
$maybe addWdgt <- addWdgts !? (1, (EnumPosition category, 0))
|
||||
$maybe addWdgt <- addWdgts !? (1, (BoundedPosition category, 0))
|
||||
^{addWdgt}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user