fixed comment propagation

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

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

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

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