chore(workflow-types): more on types

src/Model/Types/Workflow.hs

@@ -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)])])]))]

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 --
 ----------