fixed comment propagation
This commit is contained in:
David Mosbach
parent
a5a89674a7
commit
f10798511e
@ -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",
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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),
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user