122 lines
5.8 KiB
Haskell
122 lines
5.8 KiB
Haskell
{-# Language OverloadedStrings #-}
|
|
|
|
module Export where
|
|
|
|
----------------Imports----------------
|
|
|
|
import Data.Aeson
|
|
import Data.Map hiding (fromList)
|
|
import Data.Vector hiding ((!), (++))
|
|
import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..), Message(..), Label(..), Viewers (..))
|
|
import Data.Text (Text, pack)
|
|
-- import Data.YAML (Node (..))
|
|
import Data.YAML.Event (tagToText, Pos)
|
|
import Data.Maybe (fromMaybe)
|
|
import YamlParser (YAMLNode (..), AnchorData (..))
|
|
import Data.Aeson.Types (toJSONKeyText)
|
|
|
|
---------------------------------------
|
|
|
|
|
|
---------------Instances---------------
|
|
|
|
instance ToJSON Entry where
|
|
toJSON (Single s) = toJSON s
|
|
toJSON (Msg m) = toJSON m
|
|
toJSON (Vie v) = toJSON v
|
|
toJSON (Dict d) = toJSON d
|
|
toJSON (List l) = toJSON l
|
|
toJSON (Val v) = toJSON v
|
|
|
|
instance ToJSON YAMLNode where
|
|
toJSON (Scalar b c a p) = object [
|
|
"content" .= show b,
|
|
"comment" .= c,
|
|
"anchor" .= a,
|
|
"position" .= p
|
|
]
|
|
toJSON (Mapping ct cm a md p) = object [
|
|
"content" .= ct,
|
|
"comment" .= cm,
|
|
"anchor" .= a,
|
|
"position" .= p
|
|
]
|
|
toJSON (Sequence ch cm a p) = object [
|
|
"content" .= ch,
|
|
"comment" .= cm,
|
|
"anchor" .= a,
|
|
"position" .= p
|
|
]
|
|
|
|
instance ToJSONKey YAMLNode where
|
|
toJSONKey = toJSONKeyText display where
|
|
display :: YAMLNode -> Text
|
|
display (Scalar bytes _ _ _) = pack $ show bytes
|
|
|
|
instance ToJSON AnchorData where
|
|
toJSON (AnchorDef a) = object ["type" .= String "anchor", "name" .= a]
|
|
toJSON (AnchorAlias a) = object ["type" .= String "alias", "name" .= a]
|
|
toJSON NoAnchor = Null
|
|
|
|
instance ToJSON Pos
|
|
|
|
instance ToJSON Message where
|
|
toJSON (Message content status viewers comment anchor) = object [
|
|
"content" .= content,
|
|
"status" .= status,
|
|
"viewers" .= viewers,
|
|
"comment" .= comment,
|
|
"anchor" .= anchor]
|
|
|
|
instance ToJSON Viewers where
|
|
toJSON (Viewers mappings comment anchor) = object [
|
|
"viewers" .= mappings,
|
|
"comment" .= comment,
|
|
"anchor" .= anchor
|
|
]
|
|
instance ToJSON Label where
|
|
toJSON (Label fallback fallbackLang translations comment anchor) = object [
|
|
"fallback" .= fallback,
|
|
"fallback-lang" .= fallbackLang,
|
|
"translations" .= translations,
|
|
"comment" .= comment,
|
|
"anchor" .= anchor]
|
|
|
|
instance ToJSON NodeData where
|
|
toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where
|
|
newObject :: Text -> Map Text Entry -> [Value] -> [Value]
|
|
newObject ident values result = object [
|
|
"id" .= ident,
|
|
"name" .= values ! "name",
|
|
"val" .= show 5, -- Todo adjust to number of edges
|
|
"stateData" .= object [
|
|
"comment" .= values ! "comment",
|
|
"anchor" .= values ! "anchor",
|
|
"viewers" .= values ! "viewers",
|
|
"final" .= values ! "final",
|
|
"messages" .= values ! "messages",
|
|
"payload" .= values ! "payload"]] : result
|
|
-- toEncoding = genericToEncoding defaultOptions
|
|
|
|
instance ToJSON EdgeData where
|
|
toJSON (EData d) = Array (fromList $ foldrWithKey newObject [] d) where
|
|
newObject :: Text -> Map Text Entry -> [Value] -> [Value]
|
|
newObject ident values result = object [
|
|
"id" .= ident,
|
|
"name" .= values ! "name",
|
|
"source" .= values ! "source",
|
|
"target" .= values ! "target",
|
|
"actionData" .= object [
|
|
"comment" .= values ! "comment",
|
|
"anchor" .= values ! "anchor",
|
|
"mode" .= values ! "mode",
|
|
"actors" .= values ! "actors",
|
|
"viewers" .= values ! "viewers",
|
|
"actor Viewers" .= values ! "view-actor",
|
|
"messages" .= values ! "messages",
|
|
"form" .= values ! "form"]] : result
|
|
|
|
instance ToJSON GraphData where
|
|
toJSON (GData (nd, ed)) = object ["states" .= toJSON nd, "actions" .= toJSON ed]
|
|
|
|
--------------------------------------- |