chore(workflow-types): more on types
This commit is contained in:
Sarah Vaupel
Gregor Kleen
parent
460bd9d3e5
commit
d1b9d502e8
@ -4,10 +4,17 @@ import Import.NoModel
|
||||
|
||||
import Model.Types.Security (AuthDNF)
|
||||
|
||||
import qualified Data.Set as Set (toList, fromList)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Aeson.Types (Parser)
|
||||
|
||||
|
||||
data WorkflowRole userid = WorkflowRoleUser userid
|
||||
| WorkflowRoleAuthorized AuthDNF
|
||||
| WorkflowRoleInitiator userid
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
|
||||
data WorkflowGraphNodeStatus = WGNS
|
||||
@ -20,6 +27,7 @@ data WorkflowGraphNodeStatus = WGNS
|
||||
data WorkflowGraphNode = WGN
|
||||
{ wgnStatus :: WorkflowGraphNodeStatus
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
|
||||
|
||||
type WorkflowGraphNodeLabel = CI Text
|
||||
|
||||
@ -48,8 +56,13 @@ data WorkflowEdgePayloadField fileid userid (payload :: *) where
|
||||
{ wepfnLabel :: Text
|
||||
, wepfnPlaceholder :: Text
|
||||
, wepfnTooltip :: Maybe Text
|
||||
, wepfnDefault :: Maybe prec
|
||||
, wepfnDefault :: Maybe (Fixed prec)
|
||||
, wepfnPrecision :: SomeResolution
|
||||
} -> WorkflowEdgePayloadField fileid userid (Fixed prec)
|
||||
WorkflowEdgePayloadFieldBool :: { wepfbLabel :: Text
|
||||
, wepfbTooltip :: Maybe Text
|
||||
, wepfbDefault :: Maybe Bool
|
||||
} -> WorkflowEdgePayloadField fileid userid Bool
|
||||
WorkflowEdgePayloadFieldFile :: { wepffLabel :: Text
|
||||
, wepffTooltip :: Maybe Text
|
||||
, wepffDefault :: Maybe fileid
|
||||
@ -59,10 +72,27 @@ data WorkflowEdgePayloadField fileid userid (payload :: *) where
|
||||
, wepfuDefault :: Maybe userid
|
||||
} -> WorkflowEdgePayloadField fileid userid userid
|
||||
|
||||
instance forall fileid userid payload. (Eq fileid, Eq userid) => Eq (WorkflowEdgePayloadField fileid userid payload) where
|
||||
(WorkflowEdgePayloadFieldText l1 p1 tt1 d1) == (WorkflowEdgePayloadFieldText l2 p2 tt2 d2) = l1 == l2 && p1 == p2 && tt1 == tt2 && d1 == d2
|
||||
(WorkflowEdgePayloadFieldNumber l1 p1 tt1 d1 prec1) == (WorkflowEdgePayloadFieldNumber l2 p2 tt2 d2 prec2) = l1 == l2 && p1 == p2 && tt1 == tt2 && d1 == d2 && prec1 == prec2
|
||||
(WorkflowEdgePayloadFieldBool l1 tt1 d1) == (WorkflowEdgePayloadFieldBool l2 tt2 d2) = l1 == l2 && tt1 == tt2 && d1 == d2
|
||||
(WorkflowEdgePayloadFieldFile l1 tt1 d1) == (WorkflowEdgePayloadFieldFile l2 tt2 d2) = l1 == l2 && tt1 == tt2 && d1 == d2
|
||||
(WorkflowEdgePayloadFieldUser l1 tt1 d1) == (WorkflowEdgePayloadFieldUser l2 tt2 d2) = l1 == l2 && tt1 == tt2 && d1 == d2
|
||||
_ == _ = False
|
||||
|
||||
data WorkflowEdgePayloadSpecification fileid userid = forall payload. (FromJSON payload, ToJSON payload) => WorkflowEdgePayloadSpecification (WorkflowEdgePayloadField fileid userid payload)
|
||||
-- TODO remove this instance on removal of the test definition
|
||||
instance forall fileid userid payload. (Ord fileid, Ord userid) => Ord (WorkflowEdgePayloadField fileid userid payload) where
|
||||
compare _ _ = EQ
|
||||
|
||||
|
||||
data WorkflowEdgePayloadSpecification fileid userid = forall payload. WorkflowEdgePayloadSpecification (WorkflowEdgePayloadField fileid userid payload)
|
||||
|
||||
-- TODO remove (see above)
|
||||
instance Eq (WorkflowEdgePayloadSpecification fileid userid) where
|
||||
(WorkflowEdgePayloadSpecification _) == (WorkflowEdgePayloadSpecification _) = True
|
||||
instance Ord (WorkflowEdgePayloadSpecification fileid userid) where
|
||||
compare _ _ = EQ
|
||||
|
||||
data WorkflowPayload userid fileid = forall payload. Map WorkflowEdgePayloadLabel (WorkflowEdgePayload userid fileid payload)
|
||||
|
||||
|
||||
@ -72,6 +102,12 @@ data WorkflowGraphEdge userid fileid = WGE
|
||||
, wgeForm :: Map WorkflowEdgePayloadLabel (NonNull (Set (WorkflowEdgePayloadSpecification fileid userid)))
|
||||
}
|
||||
|
||||
-- TODO remove (see above)
|
||||
instance Eq (WorkflowGraphEdge userid fileid) where
|
||||
_ == _ = True
|
||||
instance Ord (WorkflowGraphEdge userid fileid) where
|
||||
compare _ _ = EQ
|
||||
|
||||
|
||||
data WorkflowGraph userid fileid = WorkflowGraph (Map WorkflowGraphNodeLabel (WorkflowGraphNode, Set (WorkflowGraphEdge userid fileid)))
|
||||
|
||||
@ -84,4 +120,139 @@ data WorkflowInstanceScope' = WISGlobal' | WISTerm' | WISSchool' | WISCourse'
|
||||
|
||||
|
||||
|
||||
deriveJSON defaultOptions ''WorkflowGraphNodeStatus
|
||||
instance (ToJSON userid) => ToJSON (WorkflowRole userid) where
|
||||
toJSON (WorkflowRoleUser uid) = JSON.object
|
||||
[ "role" JSON..= ("user" :: Text)
|
||||
, "user" JSON..= uid
|
||||
]
|
||||
toJSON (WorkflowRoleAuthorized authDNF) = JSON.object
|
||||
[ "role" JSON..= ("authorized" :: Text)
|
||||
, "authorized" JSON..= authDNF
|
||||
]
|
||||
toJSON (WorkflowRoleInitiator uid) = JSON.object
|
||||
[ "role" JSON..= ("initiator" :: Text)
|
||||
, "initiator" JSON..= uid
|
||||
]
|
||||
instance (FromJSON userid) => FromJSON (WorkflowRole userid) where
|
||||
parseJSON = JSON.withObject "WorkflowRole" $ \o -> do
|
||||
role <- (o .: "role" :: Parser Text)
|
||||
case role of
|
||||
"user" -> do
|
||||
uid <- o .: "user"
|
||||
return $ WorkflowRoleUser uid
|
||||
"authorized" -> do
|
||||
adnf <- o .: "authorized"
|
||||
return $ WorkflowRoleAuthorized adnf
|
||||
"initiator" -> do
|
||||
iid <- o .: "initiator"
|
||||
return $ WorkflowRoleInitiator iid
|
||||
_ -> do
|
||||
(error.show) $ "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
|
||||
instance (FromJSON userid, FromJSON fileid) => FromJSON (WorkflowGraph userid fileid) where
|
||||
parseJSON = parseJSON
|
||||
|
||||
instance (ToJSON userid, ToJSON fileid) => ToJSON (WorkflowGraphEdge userid fileid) where
|
||||
toJSON (WGE{..}) = JSON.object
|
||||
[ "actors" JSON..= Set.toList wgeActors
|
||||
, "target" JSON..= wgeTarget
|
||||
, "form" JSON..= wgeForm
|
||||
]
|
||||
instance (FromJSON userid, Ord userid, FromJSON fileid) => FromJSON (WorkflowGraphEdge userid fileid) where
|
||||
parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do
|
||||
wgeActors <- o .: "actors"
|
||||
wgeTarget <- o .: "target"
|
||||
wgeForm <- o .: "form"
|
||||
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
|
||||
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
|
||||
"text" -> do
|
||||
wepftLabel <- o JSON..: "label"
|
||||
wepftPlaceholder <- o JSON..: "placeholder"
|
||||
wepftTooltip <- o JSON..:? "tooltip"
|
||||
wepftDefault <- o JSON..:? "default"
|
||||
return (WorkflowEdgePayloadFieldText{..})
|
||||
"number" -> do
|
||||
wepfnLabel <- o JSON..: "label"
|
||||
wepfnPlaceholder <- o JSON..: "placeholder"
|
||||
wepfnTooltip <- o JSON..:? "tooltip"
|
||||
wepfnDefault <- (o JSON..:? "default" :: Parser (Maybe (Fixed prec)))
|
||||
wepfnPrecision <- o JSON..: "precision"
|
||||
return (WorkflowEdgePayloadFieldNumber{..})
|
||||
"bool" -> do
|
||||
wepfbLabel <- o JSON..: "label"
|
||||
wepfbTooltip <- o JSON..:? "tooltip"
|
||||
wepfbDefault <- (o JSON..:? "default" :: Parser (Maybe Bool))
|
||||
return (WorkflowEdgePayloadFieldBool{..})
|
||||
"file" -> do
|
||||
wepffLabel <- o JSON..: "label"
|
||||
wepffTooltip <- o JSON..:? "tooltip"
|
||||
wepffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid))
|
||||
return (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
|
||||
|
||||
instance ToJSON WorkflowGraphNode where
|
||||
toJSON (WGN{..}) = toJSON wgnStatus
|
||||
instance FromJSON WorkflowGraphNode where
|
||||
parseJSON = parseJSON
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''WorkflowGraphNodeStatus
|
||||
|
||||
|
||||
testGraph :: WorkflowGraph Text Text
|
||||
testGraph = WorkflowGraph $ Map.fromList [("node1", (WGN (WGNS "id" True (Just "someLabel")), Set.fromList [WGE (Set.fromList [WorkflowRoleUser "user-id", WorkflowRoleInitiator "init-user-id"]) "node1" (Map.fromList [("sometext", impureNonNull $ Set.fromList [WorkflowEdgePayloadSpecification $ WorkflowEdgePayloadFieldText "text-label" "text-placeholder" (Just "text-tooltip") (Just "text-default")]),("someuser", impureNonNull $ Set.fromList [WorkflowEdgePayloadSpecification $ WorkflowEdgePayloadFieldUser "user-label" Nothing Nothing]),("somebool", impureNonNull $ Set.fromList [WorkflowEdgePayloadSpecification $ WorkflowEdgePayloadFieldBool "bool-label" Nothing (Just True)])])]))]
|
||||
|
||||
30
src/Utils.hs
30
src/Utils.hs
@ -333,6 +333,36 @@ stepTextCounter text
|
||||
fromText :: (IsString a, Textual t) => t -> a
|
||||
fromText = fromString . unpack
|
||||
|
||||
|
||||
-----------
|
||||
-- Fixed --
|
||||
-----------
|
||||
|
||||
rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a
|
||||
rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy @a)))
|
||||
|
||||
rationalToFixed3 :: Rational -> Fixed E3
|
||||
rationalToFixed3 = rationalToFixed
|
||||
|
||||
rationalToFixed2 :: Rational -> Fixed E2
|
||||
rationalToFixed2 = rationalToFixed
|
||||
|
||||
data SomeResolution = forall prec. HasResolution prec => SomeResolution (Proxy prec)
|
||||
|
||||
instance Eq SomeResolution where
|
||||
_ == _ = True
|
||||
instance Ord SomeResolution where
|
||||
compare _ _ = EQ
|
||||
|
||||
instance FromJSON SomeResolution where
|
||||
parseJSON = parseJSON
|
||||
instance ToJSON SomeResolution where
|
||||
toJSON = toJSON
|
||||
|
||||
someResolutions :: [SomeResolution]
|
||||
someResolutions = [ SomeResolution (Proxy @E0), SomeResolution (Proxy @E1), SomeResolution (Proxy @E2), SomeResolution (Proxy @E3) ]
|
||||
|
||||
|
||||
----------
|
||||
-- Bool --
|
||||
----------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user