diff --git a/app/Export.hs b/app/Export.hs index efd0726..e2894b7 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -22,7 +22,8 @@ module Export where instance ToJSON Entry where toJSON (Single s) = toJSON s - toJSON (Msg m) = toJSON m + 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 @@ -34,6 +35,18 @@ module Export where "anchor" .= a, "position" .= p ] + toJSON (Mapping ct cm a 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 @@ -77,6 +90,8 @@ module Export where "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", @@ -92,6 +107,8 @@ module Export where "source" .= values ! "source", "target" .= values ! "target", "actionData" .= object [ + "comment" .= values ! "comment", + "anchor" .= values ! "anchor", "mode" .= values ! "mode", "actors" .= values ! "actors", "viewers" .= values ! "viewers", diff --git a/app/Main.hs b/app/Main.hs index 9498cb6..7d17e9a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,7 @@ module Main where import qualified Data.ByteString.Lazy as BS.L import Workflow (Workflow, buildData) import Export - import YamlParser (parse, ParseState (..), decodeWithComments1, decodeWithComments1Strict) + import YamlParser (parse, ParseState (..), decodeWithComments1, decodeWithComments1Strict, YAMLNode) import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) import Data.Either (isLeft, fromLeft, fromRight) import Data.List (dropWhileEnd) @@ -65,7 +65,7 @@ module Main where -- unless (isJust mainEvents) . error $ "Missing DocumentStart event" -- let initState = PState [] empty [] -- let (rootNode, state) = runState (parse $ fromJust mainEvents) initState - let decoded = decodeWithComments1 input :: Either (Pos, String) Workflow + let decoded = decodeWithComments1 input :: Either (Pos, String) YAMLNode -- Workflow print decoded -- print rootNode where -- validHead :: EvStream -> Maybe EvStream diff --git a/app/Workflow.hs b/app/Workflow.hs index f0e2da6..7fc8d1d 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -16,7 +16,8 @@ module Workflow where import Data.Text (Text, pack) import YamlParser import Data.Text.Encoding (decodeUtf8, encodeUtf8) - + import Debug.Trace (trace) + --------------------------------------- @@ -212,6 +213,8 @@ module Workflow where analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed) extract :: State -> Map Text Entry extract s = fromList [("name", Single name), + ("comment", List $ Prelude.map Single s.comment), + ("anchor", Single . pack . show $ s.anchor), ("viewers", Vie viewers), ("final", Single $ pack final), ("messages", List $ Prelude.map Msg messages), @@ -231,6 +234,8 @@ module Workflow where updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (pack $ show k ++ "_@_" ++ show targetID) (newData k action targetID) eData) e edges newData :: Text -> Action -> Text -> Map Text Entry newData ident a targetID = fromList [("name", Single name), + ("comment", List $ Prelude.map Single a.comment), + ("anchor", Single . pack . show $ a.anchor), ("source", Single source), ("target", Single targetID), ("mode", Single mode), diff --git a/app/YamlParser.hs b/app/YamlParser.hs index 5a471f0..fa8694f 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -6,12 +6,12 @@ module YamlParser where import Prelude hiding (lookup) import qualified Prelude as P import Control.Monad.State.Lazy - import Data.Map.Lazy (Map, insert, lookup, empty, fromList, toList) + import Data.Map.Lazy (Map, insert, lookup, empty, fromList, toList, (!)) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Lazy (toStrict) import Debug.Trace (trace) import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) - import Data.Text (pack, Text) + import Data.Text (pack, unpack, Text) import Data.YAML (decode1Strict, Node, Pos, Parser, parseEither) import Data.YAML.Event hiding (Scalar) import qualified Data.YAML.Event as Y @@ -120,11 +120,17 @@ module YamlParser where unless (isScalar key) . error $ "Key not a scalar: " ++ show key (maybeVal, es'') <- parseNode es' let val = fromJust maybeVal - let content' = (key {comment = []}, val {comment = key.comment}) : content -- migrate comment to val to preserve it for the workflow data structure + let content' = (key {comment = []}, val {comment = if null val.comment then key.comment else val.comment}) : content -- migrate comment to val to preserve it for the workflow data structure + when (not (null key.comment) && (safeHead . unpack . head $ key.comment) == '#' ) $ trace ("Migr to: " ++ show (snd . head $ content').comment) return() parseMapping es'' anchor content' where isScalar :: YAMLNode -> Bool isScalar (Scalar {}) = True isScalar _ = False + safeHead [] = ' ' -- TODO remove those + safeHead (x:xs) = x + showType (Scalar {}) = "Scalar" + showType (Mapping {}) = "Mapping" + showType (Sequence {}) = "Sequence" parseScalar :: Maybe Anchor -> Text -> Pos -> State ParseState YAMLNode