From ce1acec444762d254ccf07b37c280ffb02934669 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 3 Apr 2020 17:45:39 +0200 Subject: [PATCH] fix(workflow): fix types --- src/Model/Types/Workflow.hs | 115 ++++++++++++++++-------------------- 1 file changed, 52 insertions(+), 63 deletions(-) diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 30c276140..93c9190ff 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -33,11 +33,11 @@ type WorkflowGraphNodeLabel = CI Text data WorkflowEdgePayload userid fileid (payload :: *) where - WEPText :: Text -> WorkflowEdgePayload userid fileid Text - WEPNumber :: HasResolution prec => (Fixed prec) -> WorkflowEdgePayload userid fileid (Fixed prec) - WEPBool :: Bool -> WorkflowEdgePayload userid fileid Bool - WEPFile :: fileid -> WorkflowEdgePayload userid fileid fileid - WEPUser :: userid -> WorkflowEdgePayload userid fileid userid + WEPText :: Text -> WorkflowEdgePayload userid fileid Text + WEPNumber :: SomeResolution -> WorkflowEdgePayload userid fileid SomeResolution + WEPBool :: Bool -> WorkflowEdgePayload userid fileid Bool + WEPFile :: fileid -> WorkflowEdgePayload userid fileid fileid + WEPUser :: userid -> WorkflowEdgePayload userid fileid userid data WorkflowEdgePayload' = WEPText' | WEPNumber' | WEPBool' | WEPFile' | WEPUser' deriving (Eq, Ord, Enum, Show, Read, Data, Generic, Typeable) @@ -52,13 +52,12 @@ data WorkflowEdgePayloadField fileid userid (payload :: *) where , wepftTooltip :: Maybe Text , wepftDefault :: Maybe Text } -> WorkflowEdgePayloadField fileid userid Text - WorkflowEdgePayloadFieldNumber :: HasResolution prec => - { wepfnLabel :: Text + WorkflowEdgePayloadFieldNumber :: { wepfnLabel :: Text , wepfnPlaceholder :: Text , wepfnTooltip :: Maybe Text - , wepfnDefault :: Maybe (Fixed prec) + , wepfnDefault :: Maybe SomeResolution , wepfnPrecision :: SomeResolution - } -> WorkflowEdgePayloadField fileid userid (Fixed prec) + } -> WorkflowEdgePayloadField fileid userid SomeResolution WorkflowEdgePayloadFieldBool :: { wepfbLabel :: Text , wepfbTooltip :: Maybe Text , wepfbDefault :: Maybe Bool @@ -146,8 +145,7 @@ instance (FromJSON userid) => FromJSON (WorkflowRole userid) where "initiator" -> do iid <- o .: "initiator" return $ WorkflowRoleInitiator iid - _ -> do - (error.show) $ "WorkflowRole parseJSON error: expected role (user|authorized|initiator), but got " ++ role + _ -> terror $ "WorkflowRole parseJSON error: expected role (user|authorized|initiator), but got " <> role instance (ToJSON userid, ToJSON fileid) => ToJSON (WorkflowGraph userid fileid) where toJSON (WorkflowGraph m) = toJSON m @@ -168,81 +166,72 @@ instance (FromJSON userid, Ord userid, FromJSON fileid) => FromJSON (WorkflowGra return WGE{..} instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadSpecification fileid userid) where - toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldText{})) = toJSON f - toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldNumber{})) = toJSON f - toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldBool{})) = toJSON f - toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldFile{})) = toJSON f - toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldUser{})) = toJSON f + toJSON (WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldText{..}) = JSON.object + [ "tag" JSON..= ("text" :: Text) + , "label" JSON..= wepftLabel + , "placeholder" JSON..= wepftPlaceholder + , "tooltip" JSON..= wepftTooltip + , "default" JSON..= wepftDefault + ] + toJSON (WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldNumber{..}) = JSON.object + [ "tag" JSON..= ("number" :: Text) + , "label" JSON..= wepfnLabel + , "placeholder" JSON..= wepfnPlaceholder + , "tooltip" JSON..= wepfnTooltip + , "default" JSON..= wepfnDefault + , "precision" JSON..= wepfnPrecision + ] + toJSON (WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldBool{..}) = JSON.object + [ "tag" JSON..= ("bool" :: Text) + , "label" JSON..= wepfbLabel + , "tooltip" JSON..= wepfbTooltip + , "default" JSON..= wepfbDefault + ] + toJSON (WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldFile{..}) = JSON.object + [ "tag" JSON..= ("file" :: Text) + , "label" JSON..= wepffLabel + , "tooltip" JSON..= wepffTooltip + , "default" JSON..= wepffDefault + ] + toJSON (WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldUser{..}) = JSON.object + [ "tag" JSON..= ("user" :: Text) + , "label" JSON..= wepfuLabel + , "tooltip" JSON..= wepfuTooltip + , "default" JSON..= wepfuDefault + ] instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowEdgePayloadSpecification fileid userid) where - parseJSON = parseJSON -- TODO - -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid Text) where - toJSON (WorkflowEdgePayloadFieldText{..}) = JSON.object - [ "label" JSON..= wepftLabel - , "placeholder" JSON..= wepftPlaceholder - , "tooltip" JSON..= wepftTooltip - , "default" JSON..= wepftDefault - ] -instance (ToJSON fileid, ToJSON userid, HasResolution prec) => ToJSON (WorkflowEdgePayloadField fileid userid (Fixed prec)) where - toJSON (WorkflowEdgePayloadFieldNumber{..}) = JSON.object - [ "label" JSON..= wepfnLabel - , "placeholder" JSON..= wepfnPlaceholder - , "tooltip" JSON..= wepfnTooltip - , "default" JSON..= wepfnDefault - , "precision" JSON..= wepfnPrecision - ] -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid Bool) where - toJSON (WorkflowEdgePayloadFieldBool{..}) = JSON.object - [ "label" JSON..= wepfbLabel - , "tooltip" JSON..= wepfbTooltip - , "default" JSON..= wepfbDefault - ] -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid FileInfo) where - toJSON (WorkflowEdgePayloadFieldFile{..}) = JSON.object - [ "label" JSON..= wepffLabel - , "tooltip" JSON..= wepffTooltip - , "default" JSON..= wepffDefault - ] -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid userid) where - toJSON (WorkflowEdgePayloadFieldUser{..}) = JSON.object - [ "label" JSON..= wepfuLabel - , "tooltip" JSON..= wepfuTooltip - , "default" JSON..= wepfuDefault - ] - -instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowEdgePayloadField fileid userid payload) where - parseJSON = JSON.withObject "WorkflowEdgePayloadField" $ \o -> do - fieldType <- (o JSON..: "type" :: Parser Text) - case fieldType of + parseJSON = JSON.withObject "WorkflowEdgePayloadSpecification" $ \o -> do + fieldTag <- (o JSON..: "tag" :: Parser Text) + case fieldTag of "text" -> do wepftLabel <- o JSON..: "label" wepftPlaceholder <- o JSON..: "placeholder" wepftTooltip <- o JSON..:? "tooltip" wepftDefault <- o JSON..:? "default" - return (WorkflowEdgePayloadFieldText{..}) + return $ WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldText{..} "number" -> do wepfnLabel <- o JSON..: "label" wepfnPlaceholder <- o JSON..: "placeholder" wepfnTooltip <- o JSON..:? "tooltip" - wepfnDefault <- (o JSON..:? "default" :: Parser (Maybe (Fixed prec))) + wepfnDefault <- (o JSON..:? "default" :: Parser (Maybe SomeResolution)) wepfnPrecision <- o JSON..: "precision" - return (WorkflowEdgePayloadFieldNumber{..}) + return $ WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldNumber{..} "bool" -> do wepfbLabel <- o JSON..: "label" wepfbTooltip <- o JSON..:? "tooltip" wepfbDefault <- (o JSON..:? "default" :: Parser (Maybe Bool)) - return (WorkflowEdgePayloadFieldBool{..}) + return $ WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldBool{..} "file" -> do wepffLabel <- o JSON..: "label" wepffTooltip <- o JSON..:? "tooltip" wepffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid)) - return (WorkflowEdgePayloadFieldFile{..}) + return $ WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldFile{..} "user" -> do wepfuLabel <- o JSON..: "label" wepfuTooltip <- o JSON..:? "tooltip" wepfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid)) - return (WorkflowEdgePayloadFieldUser{..}) - _ -> error $ "WorkflowEdgePayloadField parseJSON error: expected field type (text|number|bool|file|user), but got " ++ fieldType + return $ WorkflowEdgePayloadSpecification WorkflowEdgePayloadFieldUser{..} + _ -> terror $ "WorkflowEdgePayloadSpecification parseJSON error: expected field tag (text|number|bool|file|user), but got " <> fieldTag instance ToJSON WorkflowGraphNode where toJSON (WGN{..}) = toJSON wgnStatus