gonito/Handler/Annotations.hs

115 lines
4.9 KiB
Haskell
Raw Normal View History

2020-07-11 14:14:35 +02:00
module Handler.Annotations where
import Import
import qualified Database.Esqueleto as E
import qualified Yesod.Table as Table
import Handler.Tables (timestampCell)
getListAnnotationsR :: Handler Html
getListAnnotationsR = do
annotations <- runDB $ selectList [] [Asc AnnotationTaskId]
defaultLayout $ do
setTitle "List annotation tasks"
$(widgetFile "list-annotations")
getAnnotationTaskR :: AnnotationTaskId -> Handler Html
getAnnotationTaskR annotationTaskId = do
(Entity userId _) <- requireAuth
annotationTask <- runDB $ get annotationTaskId
-- Get all labels
labels <- runDB $ selectList [AnnotationLabelAnnotationTask ==. annotationTaskId] [Asc AnnotationLabelOrder]
-- Get list of user decisions for this annotation task
taskDecisionIds' <- runDB $ E.select
$ E.from $ \(annotationItem `E.InnerJoin` annotationDecision) -> do
E.on (annotationItem E.^. AnnotationItemId E.==. annotationDecision E.^. AnnotationDecisionAnnotationItem)
E.where_ (annotationItem E.^. AnnotationItemAnnotationTask E.==. E.val annotationTaskId
E.&&. annotationDecision E.^. AnnotationDecisionUser E.==. E.val userId)
return $ annotationDecision E.^. AnnotationDecisionAnnotationItem
let decisionLength = length taskDecisionIds'
-- Get number of items for this annotation task
taskItemsLength <- runDB $ count [AnnotationItemAnnotationTask ==. annotationTaskId]
-- Get first item to annotate which was not annotated
let taskDecisionIds = map E.unValue taskDecisionIds'
maybeItem <- runDB $ selectFirst [AnnotationItemAnnotationTask ==. annotationTaskId,
AnnotationItemId /<-. taskDecisionIds] [Asc AnnotationItemOrder]
let allDone = decisionLength == taskItemsLength && decisionLength > 0
defaultLayout $ do
setTitle "Annotation task"
$(widgetFile "annotation-task")
postAnnotationTaskDecisionR :: AnnotationTaskId -> AnnotationItemId -> AnnotationLabelId -> Handler Html
postAnnotationTaskDecisionR annotationTaskId itemId labelId = do
(Entity userId _) <- requireAuth
now <- liftIO getCurrentTime
label <- runDB $ get404 labelId
-- Check decision exists
maybeSaveDecision <- runDB $ selectFirst [AnnotationDecisionAnnotationItem ==. itemId,
AnnotationDecisionUser ==. userId] []
case maybeSaveDecision of
-- Update if exists
Nothing -> do
_ <- runDB $ insert $ AnnotationDecision itemId userId (annotationLabelValue label) now
return ()
-- Insert new
Just (Entity saveDecisionId _) -> do
_ <- runDB $ updateWhere [AnnotationDecisionId ==. saveDecisionId] [AnnotationDecisionValue =. annotationLabelValue label,
AnnotationDecisionStamp =. now]
return ()
-- Redirect to annotation page
redirect $ AnnotationTaskR annotationTaskId
getAnnotationTaskResultsR :: AnnotationTaskId -> Handler Html
getAnnotationTaskResultsR annotationTaskId = do
results <- runDB $ E.select
$ E.from $ \(annotationDecision `E.InnerJoin` annotationItem) -> do
E.on (annotationDecision E.^. AnnotationDecisionAnnotationItem E.==. annotationItem E.^. AnnotationItemId)
E.where_ (annotationItem E.^. AnnotationItemAnnotationTask E.==. E.val annotationTaskId)
E.orderBy [E.asc (annotationItem E.^. AnnotationItemOrder),
E.asc (annotationDecision E.^. AnnotationDecisionUser)]
return (annotationItem E.^. AnnotationItemContent,
annotationItem E.^. AnnotationItemOrder,
annotationDecision E.^. AnnotationDecisionValue)
labels <- runDB $ selectList [AnnotationLabelAnnotationTask ==. annotationTaskId] [Asc AnnotationLabelOrder]
defaultLayout $ do
setTitle "Annotation task results"
$(widgetFile "annotation-task-results")
annotationListTable :: Table.Table App (Entity AnnotationTask)
annotationListTable = mempty
++ Table.text "Name" (annotationTaskName . entityVal)
++ Table.linked "Annotation link" (const "Annotation link") (AnnotationTaskR . entityKey)
++ Table.linked "Results link" (const "Results link") (AnnotationTaskResultsR . entityKey)
++ timestampCell "Date added" (annotationTaskAdded . entityVal)
annotationResultsTable :: Table.Table App (E.Value Text, E.Value Int, E.Value Text)
annotationResultsTable = mempty
++ Table.int "ID" (\(_, order, _) -> E.unValue order)
++ Table.text "Answer value" (\(_, _, answer) -> E.unValue answer)
++ Table.text "Text" (\(content, _, _) -> E.unValue content)
annotationLabelsTable :: Table.Table App (Entity AnnotationLabel)
annotationLabelsTable = mempty
++ Table.text "Answer value" (annotationLabelValue . entityVal)
++ Table.text "Text" (annotationLabelName . entityVal)