From a5a89674a74bc2ff3ac38d09bcd78d28a2300362 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 00:35:55 +0200 Subject: [PATCH 1/9] WIP: preserving comments & anchors --- app/Export.hs | 58 +++++++++- app/Index.hs | 59 +++++----- app/Main.hs | 55 +++++++-- app/Workflow.hs | 235 +++++++++++++++++++++++++------------- app/YamlParser.hs | 199 ++++++++++++++++++++++++++++++++ workflow-visualiser.cabal | 7 +- 6 files changed, 487 insertions(+), 126 deletions(-) create mode 100644 app/YamlParser.hs diff --git a/app/Export.hs b/app/Export.hs index b8a51c3..efd0726 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -6,9 +6,14 @@ module Export where import Data.Aeson import Data.Map hiding (fromList) - import Data.Vector hiding ((!)) - import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..)) - import Data.Text (pack) + 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) --------------------------------------- @@ -17,13 +22,56 @@ module Export where instance ToJSON Entry where toJSON (Single s) = toJSON s + toJSON (Msg m) = toJSON m 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 + ] + + 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 :: String -> Map String Entry -> [Value] -> [Value] + newObject :: Text -> Map Text Entry -> [Value] -> [Value] newObject ident values result = object [ "id" .= ident, "name" .= values ! "name", @@ -37,7 +85,7 @@ module Export where instance ToJSON EdgeData where toJSON (EData d) = Array (fromList $ foldrWithKey newObject [] d) where - newObject :: String -> Map String Entry -> [Value] -> [Value] + newObject :: Text -> Map Text Entry -> [Value] -> [Value] newObject ident values result = object [ "id" .= ident, "name" .= values ! "name", diff --git a/app/Index.hs b/app/Index.hs index 73a7fca..dfac639 100644 --- a/app/Index.hs +++ b/app/Index.hs @@ -6,47 +6,48 @@ module Index where - import Data.Yaml import Control.Applicative hiding (empty) import GHC.Generics (Generic) import Data.Map import Data.Maybe (fromMaybe, fromJust) + import Data.Text (Text) + import YamlParser - type Index = Map String Entry + type Index = Map Text Entry data Entry = Entry { - graphFile :: String, - category :: Maybe String, - defScope :: Maybe String, + graphFile :: Text, + category :: Maybe Text, + defScope :: Maybe Text, defDescription :: Maybe Description, instDescription :: Maybe Description, - instances :: Value - } deriving (Show, Generic) + instances :: YAMLNode + } deriving Show - instance FromJSON Entry where - parseJSON (Object o) = Entry <$> - o .: "graph-file" <*> - o .:? "category" <*> - o .:? "definition-scope" <*> - o .:? "definition-description" <*> - o .:? "instance-description" <*> - o .: "instances" - parseJSON _ = error "Unexpected yaml" + instance FromYAML' Entry where + fromYAML (Mapping mapping _ _ _) = Entry + <$> mapping <| "graph-file" + <*> mapping <|? "category" + <*> mapping <|? "definition-scope" + <*> mapping <|? "definition-description" + <*> mapping <|? "instance-description" + <*> mapping <| "instances" + -- parseJSON _ = error "Unexpected yaml" - type Title = String - type Content = String + type Title = Text + type Content = Text data Description = Description { - fallbackLang :: Maybe String, + fallbackLang :: Maybe Text, fallback :: (Maybe Title, Maybe Content), - translations :: Map String (Maybe Title, Maybe Content) - } deriving (Show, Generic) + translations :: Map Text (Maybe Title, Maybe Content) + } deriving Show - instance FromJSON Description where - parseJSON (Object o) = Description <$> - o .:? "fallback-lang" <*> - o .: "fallback" <*> - o .: "translations" + instance FromYAML' Description where + fromYAML (Mapping mapping _ _ _) = Description + <$> mapping <|? "fallback-lang" + <*> mapping <| "fallback" + <*> mapping <| "translations" english = "en-eu"; @@ -59,8 +60,8 @@ module Index where def = description.fallback in findWithDefault def english description.translations - getEntryByFile :: String -> Index -> Entry + getEntryByFile :: Text -> Index -> Entry getEntryByFile file index = query (elems index) file where - query :: [Entry] -> String -> Entry - query [] _ = error $ "No entries left for " ++ file + query :: [Entry] -> Text -> Entry + query [] _ = error $ "No entries left for " ++ show file query (x:xs) file = if x.graphFile == file then x else query xs file \ No newline at end of file diff --git a/app/Main.hs b/app/Main.hs index 65636e8..9498cb6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,14 +2,16 @@ module Main where ----------------Imports---------------- + import Prelude hiding (lookup) import System.Environment (getArgs) import System.Directory - import Data.Yaml (ParseException, decodeEither', Value (String, Null)) import Data.Aeson (encode, encodeFile) import qualified Data.ByteString.Char8 as BS + import qualified Data.ByteString.Lazy as BS.L import Workflow (Workflow, buildData) import Export + import YamlParser (parse, ParseState (..), decodeWithComments1, decodeWithComments1Strict) import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) import Data.Either (isLeft, fromLeft, fromRight) import Data.List (dropWhileEnd) @@ -17,6 +19,16 @@ module Main where import Text.Regex.TDFA ((=~)) import Index (Index, Entry (Entry), getDefDescription, getInstDescription, getEntryByFile) import Data.Char (isSpace) + + import Data.Text (pack, Text) + import Data.YAML (decode1Strict, Node, Pos, Parser, parseEither) + import Data.YAML.Event hiding (Scalar) + import Control.Monad (forM_) + import Control.Monad.State.Lazy + import Data.Map.Lazy (Map, insert, lookup, empty) + import Data.Text.Encoding (encodeUtf8, decodeUtf8) + import Data.Text.Lazy (toStrict) + import Debug.Trace (trace) --------------------------------------- @@ -29,11 +41,36 @@ module Main where main :: IO () main = getArgs >>= process >>= finish where process :: [String] -> IO Bool + process [path] = runParser path >> return True process args@[_, _] = generateJSON args >> return False process args@["--all", src, to] = processDirectory src to >> return False process _ = print "Please provide (1) a source and (2) a target file or provide '--all' and (1) a source and (2) a target directory" >> return True finish :: Bool -> IO () finish abort = if abort then return () else print "Done." + + + printEvents :: FilePath -> IO () + printEvents path = do + input <- BS.L.readFile path + forM_ (take 700 $ parseEvents input) $ \ev -> case ev of + Left _ -> error "Failed to parse" + Right event -> putStrLn (show (eEvent event) ++ " @" ++ show (posLine $ ePos event)) + + + runParser :: FilePath -> IO () + runParser path = do + input <- BS.L.readFile path + -- let events = parseEvents input + -- let mainEvents = validHead events + -- 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 + print decoded + -- print rootNode where + -- validHead :: EvStream -> Maybe EvStream + -- validHead ((Right (EvPos StreamStart _)):(Right (EvPos (DocumentStart _) _)):es) = Just es + -- validHead _ = Nothing @@ -44,8 +81,8 @@ module Main where -- print $ head args -- print $ last args content <- BS.readFile (head args) - let decoded = decodeEither' content :: Either ParseException Workflow - if isLeft decoded then throw (fromLeft undefined decoded) else do + let decoded = decodeWithComments1Strict content :: Either (Pos, String) Workflow + if isLeft decoded then error (show $ fromLeft undefined decoded) else do let yaml = fromRight undefined decoded -- let GData (nodeData, edgeData) = buildData yaml -- putStrLn $ "\nNode Data:\n\n" ++ show nodeData @@ -81,25 +118,25 @@ module Main where in (match, relative, absolute) writeIndex :: Index -> [(String, FilePath)] -> String -> IO () -- content of _index.yaml -> targets -> content for index.json writeIndex index [] content = print index >> writeFile (to ++ "/index.json") ('[':content) - writeIndex index (x:xs) content = let entry = findEntry (fst x) index + writeIndex index (x:xs) content = let entry = findEntry (pack $ fst x) index (name1, description1) = getDefDescription entry (name2, description2) = getInstDescription entry name = if isJust name1 then name1 else name2 description = if isJust description1 then description1 else description2 url = snd x format = dropWhileEnd isSpace . map (\y -> if y == '\n' then ' ' else y) - newContent = (if null xs then "" else ",\n") ++ "{\n\"name\": \"" ++ format (fromMaybe (snd x) name) + newContent = (if null xs then "" else ",\n") ++ "{\n\"name\": \"" ++ format (show $ fromMaybe (pack $ snd x) name) ++ "\",\n\"description\": \"" - ++ format (fromMaybe "" description) ++ "\",\n\"url\": \"" ++ url ++ "\"}" + ++ format (show $ fromMaybe (pack "") description) ++ "\",\n\"url\": \"" ++ url ++ "\"}" in writeIndex index xs (newContent ++ content) decodeIndex :: FilePath -> IO Index decodeIndex path = do content <- BS.readFile path - let decoded = decodeEither' content :: Either ParseException Index + let decoded = decodeWithComments1Strict content :: Either (Pos, String) Index if isLeft decoded - then throw (fromLeft undefined decoded) + then error $ show (fromLeft undefined decoded) else return $ fromRight undefined decoded - findEntry :: String -> Index -> Entry + findEntry :: Text -> Index -> Entry findEntry file index = getEntryByFile file index diff --git a/app/Workflow.hs b/app/Workflow.hs index 36ebbb8..f0e2da6 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -8,12 +8,14 @@ module Workflow where ----------------Imports---------------- - import Data.Yaml + import Data.YAML hiding (Scalar, Mapping, Sequence) import Control.Applicative hiding (empty) import GHC.Generics (Generic) import Data.Map import Data.Maybe (fromMaybe, isNothing, fromJust) - import Data.Text (pack) + import Data.Text (Text, pack) + import YamlParser + import Data.Text.Encoding (decodeUtf8, encodeUtf8) --------------------------------------- @@ -22,96 +24,165 @@ module Workflow where -- | Outer structure of a workflow, i.e. nodes and stages. data Workflow = Workflow { - nodes :: Map String State, - stages :: Maybe Value - } deriving (Show, Generic) + nodes :: Map Text State, + stages :: Maybe YAMLNode, + anchor :: AnchorData + } deriving Show - instance FromJSON Workflow + instance FromYAML' Workflow where + fromYAML (Mapping mapping _ anchor pos) = Workflow + <$> mapping <| "nodes" + <*> mapping <|? "stages" + <*> pure anchor -- | Structure of a node. data State = State { viewers :: Maybe StateViewers, - payload :: Maybe (Map String Value), + payload :: Maybe (Map Text YAMLNode), final :: Maybe Final, - edges :: Maybe (Map String Action), - messages :: Maybe [Value] - } deriving (Show, Generic) + edges :: Maybe (Map Text Action), + messages :: Maybe [Message], + comment :: [Comment], + anchor :: AnchorData + } deriving Show - instance FromJSON State where - parseJSON (Object o) = State <$> - o .:? "viewers" <*> - o .:? "payload-view" <*> - o .:? "final" <*> - o .:? "edges" <*> - o .:? "messages" - parseJSON _ = error "unexpected state data format" + instance FromYAML' State where + fromYAML (Mapping mapping comment anchor _) = State + <$> mapping <|? "viewers" + <*> mapping <|? "payload-view" + <*> mapping <|? "final" + <*> mapping <|? "edges" + <*> mapping <|? "messages" + <*> pure comment + <*> pure anchor -- | Wrapper for the `final` value of any node. - newtype Final = Final {final :: String} deriving (Show, Generic) + data Final = Final { + final :: String, + comment :: [Comment], + anchor :: AnchorData + } deriving Show - instance FromJSON Final where - parseJSON v = case v of - String _ -> Final <$> parseJSON v - Bool x -> Final <$> parseJSON (String . pack . show $ x) + instance FromYAML' Final where + fromYAML (Scalar bytes comment anchor _) = Final + <$> pure (show $ decodeUtf8 bytes) + <*> pure comment + <*> pure anchor + + -- case scalar of + -- SStr x -> pure . Final $ show x + -- SBool x -> pure . Final $ show x -- | Structure of the `viewers` object of any node. data StateViewers = StateViewers { - name :: Either Label String, - viewers :: Maybe [Map String Value] - } deriving (Show, Generic) + name :: Either Label Text, + viewers :: Maybe Viewers, + comment :: [Comment], + anchor :: AnchorData + } deriving Show - instance FromJSON StateViewers where - parseJSON (Object o) = StateViewers <$> - ((Left <$> o .: "display-label") <|> (Right <$> o .: "display-label")) <*> - o .:? "viewers" - parseJSON _ = error "unexpected stateViewers data format" + instance FromYAML' StateViewers where + fromYAML (Mapping mapping comment anchor _) = StateViewers + <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label")) + <*> mapping <|? "viewers" + <*> pure comment + <*> pure anchor + + + data Viewers = Viewers { + viewers :: [Map Text YAMLNode], + comment :: [Comment], + anchor :: AnchorData + } deriving Show + + instance FromYAML' Viewers where + fromYAML (Sequence seq comment anchor _) = Viewers + <$> pure (Prelude.map (toV empty) seq) + <*> pure comment + <*> pure anchor where + toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode + toV m (Mapping [] _ _ _) = m + toV m (Mapping ((Scalar b _ _ _,v):xs) c a p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a p) -- | Structure of the @display-label@ object of any node or edge. data Label = Label { - fallback :: Maybe String, - translations :: Maybe Value - } deriving (Show, Generic) + fallback :: Maybe Text, + fallbackLang :: Maybe Text, + translations :: Maybe YAMLNode, + comment :: [Comment], + anchor :: AnchorData + } deriving Show - instance FromJSON Label + instance FromYAML' Label where + fromYAML (Mapping mapping comment anchor _) = Label + <$> mapping <|? "fallback" + <*> mapping <|? "fallback-lang" + <*> mapping <|? "translations" + <*> pure comment + <*> pure anchor -- | Structure of an edge. data Action = Action { - mode :: Maybe String, - source :: Maybe String, + mode :: Maybe Text, + source :: Maybe Text, name :: Maybe Label, - actors :: Maybe [Map String Value], - viewActor :: Maybe [Map String Value], - viewers :: Maybe [Map String Value], - messages :: Maybe [Value], - form :: Maybe Value - } deriving (Show, Generic) + actors :: Maybe Viewers, + viewActor :: Maybe Viewers, + viewers :: Maybe Viewers, + messages :: Maybe [Message], + form :: Maybe YAMLNode, + comment :: [Comment], + anchor :: AnchorData + } deriving Show - instance FromJSON Action where - parseJSON (Object o) = Action <$> - o .:? "mode" <*> - o .:? "source" <*> - o .:? "display-label" <*> - o .:? "actors" <*> - o .:? "view-actor" <*> - o .:? "viewers" <*> - o .:? "messages" <*> - o .:? "form" - parseJSON _ = error "unexpected action data format" + instance FromYAML' Action where + fromYAML (Mapping mapping comment anchor _) = Action + <$> mapping <|? "mode" + <*> mapping <|? "source" + <*> mapping <|? "display-label" + <*> mapping <|? "actors" + <*> mapping <|? "view-actor" + <*> mapping <|? "viewers" + <*> mapping <|? "messages" + <*> mapping <|? "form" + <*> pure comment + <*> pure anchor + + data Message = Message { + content :: Label, + status :: Maybe Text, + viewers :: Maybe Viewers, + comment :: [Comment], + anchor :: AnchorData + } deriving Show + + instance FromYAML' Message where + fromYAML (Mapping mapping comment anchor _) = Message + <$> mapping <| "content" + <*> mapping <|? "status" + <*> mapping <|? "viewers" + <*> pure comment + <*> pure anchor - data Entry = Single String | Dict (Map String Value) | List [Entry] | Val Value deriving(Show, Generic) + data Entry = Single Text + | Msg Message + | Vie Viewers + | Dict (Map Text YAMLNode) + | List [Entry] + | Val YAMLNode deriving Show -- | Data of all nodes prepared for JSON encoding. - newtype NodeData = NData (Map String (Map String Entry)) deriving (Show, Generic) + newtype NodeData = NData (Map Text (Map Text Entry)) deriving (Show, Generic) -- | Data of all edges prepared for JSON encoding. - newtype EdgeData = EData (Map String (Map String Entry)) deriving (Show, Generic) + newtype EdgeData = EData (Map Text (Map Text Entry)) deriving (Show, Generic) -- | Data of the entire workflow prepared for JSON encoding. newtype GraphData = GData (NodeData , EdgeData) deriving (Show, Generic) @@ -130,53 +201,55 @@ module Workflow where buildData :: Workflow -> GraphData buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where - nodes = insert initID (State {final = Just $ Final "False", - viewers = Just $ StateViewers (Left (Label (Just initID) Nothing)) Nothing, + nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor, + viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor)) Nothing [] NoAnchor, payload = Nothing, edges = Nothing, - messages = Nothing}) wf.nodes - analyse :: String -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData) + messages = Nothing, + comment = [], + anchor = NoAnchor}) wf.nodes + analyse :: Text -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData) analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed) - extract :: State -> Map String Entry + extract :: State -> Map Text Entry extract s = fromList [("name", Single name), - ("viewers", List $ Prelude.map Dict viewers), - ("final", Single final), - ("messages", List $ Prelude.map Val messages), + ("viewers", Vie viewers), + ("final", Single $ pack final), + ("messages", List $ Prelude.map Msg messages), ("payload", payload)] where (name, viewers) = case s.viewers of - Nothing -> ("", [empty :: Map String Value]) + Nothing -> ("", Viewers [] [] NoAnchor) Just x -> case x.name of - Left y -> (fromMaybe "" y.fallback, fromMaybe [empty :: Map String Value] x.viewers) - Right y -> (y, fromMaybe [empty :: Map String Value] x.viewers) + Left y -> (fromMaybe "" y.fallback, fromMaybe (Viewers [] [] NoAnchor) x.viewers) + Right y -> (y, fromMaybe (Viewers [] [] NoAnchor) x.viewers) final = case s.final of Nothing -> "" Just x -> x.final messages = fromMaybe [] s.messages - payload = maybe (Val Null) Dict s.payload - updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData + payload = maybe (Val (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0))) Dict s.payload + updateEdges :: Text -> Maybe (Map Text Action) -> EdgeData -> EdgeData updateEdges _ Nothing e = e - updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (k ++ "_@_" ++ targetID) (newData k action targetID) eData) e edges - newData :: String -> Action -> String -> Map String Entry + 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), ("source", Single source), ("target", Single targetID), ("mode", Single mode), - ("actors", List $ Prelude.map Dict actors), - ("viewers", List $ Prelude.map Dict viewers), - ("view-actor", List $ Prelude.map Dict viewActor), - ("messages", List $ Prelude.map Val messages), + ("actors", Vie actors), + ("viewers", Vie viewers), + ("view-actor", Vie viewActor), + ("messages", List $ Prelude.map Msg messages), ("form", Val form)] where name = if isNothing a.name then ident else case (fromJust a.name).fallback of - Nothing -> show a.name + Nothing -> pack $ show a.name Just x -> x source = fromMaybe initID a.source mode = fromMaybe "" a.mode - actors = fromMaybe [] a.actors - viewers = fromMaybe [] a.viewers - viewActor = fromMaybe [] a.viewActor + actors = fromMaybe (Viewers [] [] NoAnchor) a.actors + viewers = fromMaybe (Viewers [] [] NoAnchor) a.viewers + viewActor = fromMaybe (Viewers [] [] NoAnchor) a.viewActor messages = fromMaybe [] a.messages - form = fromMaybe Null a.form + form = fromMaybe (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0)) a.form --------------------------------------- \ No newline at end of file diff --git a/app/YamlParser.hs b/app/YamlParser.hs new file mode 100644 index 0000000..5a471f0 --- /dev/null +++ b/app/YamlParser.hs @@ -0,0 +1,199 @@ +{-# Language DuplicateRecordFields, + NoFieldSelectors, + OverloadedRecordDot #-} + +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.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.YAML (decode1Strict, Node, Pos, Parser, parseEither) + import Data.YAML.Event hiding (Scalar) + import qualified Data.YAML.Event as Y + import qualified Data.ByteString.Char8 as BS + import qualified Data.ByteString.Lazy as BS.L + + activateTrace = False + + showTrace :: EvPos -> a -> a + showTrace event action = if activateTrace + then trace (show (eEvent event) ++ " @" ++ show (posLine $ ePos event)) action + else action + + data ParseState = PState { + rootNodes :: [YAMLNode], + anchors :: Map Text YAMLNode, + comments :: [Comment] -- YAML comment queue for the next node. + } + + data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq) + + + data YAMLNode = + Scalar { + bytes :: BS.ByteString, + {-tag :: Tag,-} + {-style :: Style,-} + comment :: [Comment], -- TODO every node preceded by a scalar preceded by a comment stores said comment + anchorData :: AnchorData, + pos :: Pos + } | Mapping { + content :: [(YAMLNode, YAMLNode)], + comment :: [Comment], + anchorData :: AnchorData, + pos :: Pos + } | Sequence { + children :: [YAMLNode], + comment :: [Comment], + anchorData :: AnchorData, + pos :: Pos + } deriving Show + + + type Comment = Text + + parse :: EvStream -> State ParseState YAMLNode + parse ((Right (EvPos (DocumentEnd _) pos)):_) = get >>= \pState -> return $ if length pState.rootNodes == 1 + then head pState.rootNodes + else Sequence pState.rootNodes [] NoAnchor pos + parse es = do + (root, es') <- parseNode es + pState <- get + when (isJust root) . put $ pState {rootNodes = fromJust root : pState.rootNodes} + parse es' + + parseComment :: EvStream -> State ParseState EvStream + parseComment ((Right (EvPos (Y.Comment comment) _)):es) = do + pState <- get + put $ pState {comments = comment : pState.comments} + parseComment es + parseComment es = return es + + + parseNode :: EvStream -> State ParseState (Maybe YAMLNode, EvStream) + parseNode [] = error "Unexpected eof" + parseNode ((Left _):es) = error "Failed to parse" + parseNode es@((Right (EvPos event pos)):es') = do + pState <- get + showTrace (EvPos event pos) $ case event of + Y.Comment _ -> parseComment es >>= parseNode + Y.SequenceStart anchor _ _ -> parseSequence es' anchor [] >>= \(seq, es'') -> return (Just seq, es'') + Y.MappingStart anchor _ _ -> parseMapping es' anchor [] >>= \(map, es'') -> return (Just map, es'') + Y.Scalar anchor _ _ text -> parseScalar anchor text pos >>= \scal -> return (Just scal, es') + Y.Alias anchor -> parseAlias anchor >>= \a -> return (Just a, es') + _ -> return (Nothing, es) -- error $ "Unexpected event: " ++ show event ++ " @" ++ show (posLine pos) + + + parseSequence :: EvStream -> Maybe Anchor -> [YAMLNode] -> State ParseState (YAMLNode, EvStream) + parseSequence ((Right (EvPos SequenceEnd pos)):es) anchor children = showTrace (EvPos SequenceEnd pos) $ do + pState <- get + let anchorData = maybe NoAnchor AnchorDef anchor + let seq = Sequence (reverse children) [] anchorData pos + let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) seq pState.anchors + put $ pState {anchors = anchors} + return (seq, es) + parseSequence es anchor children = do + (child, es') <- parseNode es + case child of + Nothing -> parseSequence es' anchor children + Just c -> parseSequence es' anchor (c : children) + + + parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> State ParseState (YAMLNode, EvStream) + parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content = showTrace (EvPos MappingEnd pos) $ do + pState <- get + let anchorData = maybe NoAnchor AnchorDef anchor + let map = Mapping (reverse content) [] anchorData pos + let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) map pState.anchors + put $ pState {anchors = anchors} + return (map, es) + parseMapping es anchor content = do + (maybeKey, es') <- parseNode es + case maybeKey of + Nothing -> parseMapping es' anchor content + Just key -> do + 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 + parseMapping es'' anchor content' where + isScalar :: YAMLNode -> Bool + isScalar (Scalar {}) = True + isScalar _ = False + + + parseScalar :: Maybe Anchor -> Text -> Pos -> State ParseState YAMLNode + parseScalar anchor text pos = do + pState <- get + let comments = pState.comments + let anchorData = maybe NoAnchor AnchorDef anchor + let scal = Scalar (encodeUtf8 text) comments anchorData pos + let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) scal pState.anchors + put $ pState {anchors = anchors, comments = []} + return scal + + + parseAlias :: Anchor -> State ParseState YAMLNode + parseAlias anchor = do + pState <- get + case lookup anchor pState.anchors of + Nothing -> error $ "Anchor '" ++ show anchor ++ "' not defined" + Just node -> return node {anchorData = AnchorAlias anchor} + + + class FromYAML' a where + fromYAML :: YAMLNode -> Parser a + + instance FromYAML' a => FromYAML' (Maybe a) where + fromYAML y@(Scalar bs _ _ _) + | decodeUtf8 bs == pack "null" = pure Nothing + | otherwise = Just <$> fromYAML y + fromYAML y = Just <$> fromYAML y + + instance (Ord k, FromYAML' k, FromYAML' v) => FromYAML' (Map k v) where + fromYAML (Mapping c _ _ _) = fromList <$> mapM (\(a,b) -> (,) <$> fromYAML a <*> fromYAML b) c + + instance FromYAML' Text where + fromYAML (Scalar bs _ _ _) = pure $ decodeUtf8 bs + + instance FromYAML' YAMLNode where + fromYAML = pure + + instance FromYAML' v => FromYAML' [v] where + fromYAML (Sequence c _ _ _) = mapM fromYAML c + + instance (FromYAML' a, FromYAML' b) => FromYAML' (a,b) where + fromYAML (Sequence [n1, n2] _ _ _) = (,) <$> fromYAML n1 + <*> fromYAML n2 + + decodeWithComments1 :: FromYAML' v => BS.L.ByteString -> Either (Pos, String) v + decodeWithComments1 input = do + let events = parseEvents input + let mainEvents = validHead events + unless (isJust mainEvents) . error $ "Missing DocumentStart event" + let initState = PState [] empty [] + let content = evalState (parse $ fromJust mainEvents) initState + parseEither . fromYAML $ content + where + validHead :: EvStream -> Maybe EvStream + validHead ((Right (EvPos StreamStart _)):(Right (EvPos (DocumentStart _) _)):es) = Just es + validHead _ = Nothing + + decodeWithComments1Strict :: FromYAML' v => BS.ByteString -> Either (Pos, String) v + decodeWithComments1Strict = decodeWithComments1 . BS.L.fromChunks . (:[]) + + + (<|) :: FromYAML' a => [(YAMLNode, YAMLNode)] -> Text -> Parser a + mapping <| key = maybe (fail $ "key " ++ show key ++ " not found") fromYAML (P.lookup key $ prep mapping) where + prep :: [(YAMLNode, YAMLNode)] -> [(Text, YAMLNode)] + prep mapping = [(decodeUtf8 scalar.bytes, val) | (scalar, val) <- mapping] + + (<|?) :: FromYAML' a => [(YAMLNode, YAMLNode)] -> Text -> Parser (Maybe a) + mapping <|? key = maybe (pure Nothing) fromYAML (P.lookup key $ prep mapping) where + prep :: [(YAMLNode, YAMLNode)] -> [(Text, YAMLNode)] + prep mapping = [(decodeUtf8 scalar.bytes, val) | (scalar, val) <- mapping] \ No newline at end of file diff --git a/workflow-visualiser.cabal b/workflow-visualiser.cabal index 8ef928a..5c5f306 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -27,18 +27,21 @@ executable workflow-visualiser -- Modules included in this executable, other than Main. other-modules: Workflow, Export, - Index + Index, + YamlParser -- LANGUAGE extensions used by modules in this package. -- other-extensions: build-depends: base ^>=4.16.3.0, yaml >= 0.11.11.0, + HsYAML, aeson >= 2.1.2.0, bytestring, containers, text, vector, directory, - regex-tdfa + regex-tdfa, + mtl hs-source-dirs: app default-language: Haskell2010 -- 2.39.2 From f10798511eface5a9e3a3ae0a317bf87f942acb8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 02:32:47 +0200 Subject: [PATCH 2/9] fixed comment propagation --- app/Export.hs | 19 ++++++++++++++++++- app/Main.hs | 4 ++-- app/Workflow.hs | 7 ++++++- app/YamlParser.hs | 12 +++++++++--- 4 files changed, 35 insertions(+), 7 deletions(-) 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 -- 2.39.2 From 06b690c5a18851c9f3dcf6a6e045f968e9a162de Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 03:39:33 +0200 Subject: [PATCH 3/9] merge mappings after merge key << --- app/Export.hs | 12 +++---- app/Index.hs | 22 ++++++------- app/Workflow.hs | 84 +++++++++++++++++++++++------------------------ app/YamlParser.hs | 49 ++++++++++++++++++--------- 4 files changed, 92 insertions(+), 75 deletions(-) diff --git a/app/Export.hs b/app/Export.hs index e2894b7..090c6a3 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -35,12 +35,12 @@ module Export where "anchor" .= a, "position" .= p ] - toJSON (Mapping ct cm a p) = object [ - "content" .= ct, - "comment" .= cm, - "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, diff --git a/app/Index.hs b/app/Index.hs index dfac639..b73f3d7 100644 --- a/app/Index.hs +++ b/app/Index.hs @@ -25,13 +25,13 @@ module Index where } deriving Show instance FromYAML' Entry where - fromYAML (Mapping mapping _ _ _) = Entry - <$> mapping <| "graph-file" - <*> mapping <|? "category" - <*> mapping <|? "definition-scope" - <*> mapping <|? "definition-description" - <*> mapping <|? "instance-description" - <*> mapping <| "instances" + fromYAML (Mapping mapping _ _ _ _) = Entry + <$> mapping <| "graph-file" + <*> mapping <|? "category" + <*> mapping <|? "definition-scope" + <*> mapping <|? "definition-description" + <*> mapping <|? "instance-description" + <*> mapping <| "instances" -- parseJSON _ = error "Unexpected yaml" type Title = Text @@ -44,10 +44,10 @@ module Index where } deriving Show instance FromYAML' Description where - fromYAML (Mapping mapping _ _ _) = Description - <$> mapping <|? "fallback-lang" - <*> mapping <| "fallback" - <*> mapping <| "translations" + fromYAML (Mapping mapping _ _ _ _) = Description + <$> mapping <|? "fallback-lang" + <*> mapping <| "fallback" + <*> mapping <| "translations" english = "en-eu"; diff --git a/app/Workflow.hs b/app/Workflow.hs index 7fc8d1d..0446888 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -31,10 +31,10 @@ module Workflow where } deriving Show instance FromYAML' Workflow where - fromYAML (Mapping mapping _ anchor pos) = Workflow - <$> mapping <| "nodes" - <*> mapping <|? "stages" - <*> pure anchor + fromYAML (Mapping mapping _ anchor _ pos) = Workflow + <$> mapping <| "nodes" + <*> mapping <|? "stages" + <*> pure anchor -- | Structure of a node. @@ -49,14 +49,14 @@ module Workflow where } deriving Show instance FromYAML' State where - fromYAML (Mapping mapping comment anchor _) = State - <$> mapping <|? "viewers" - <*> mapping <|? "payload-view" - <*> mapping <|? "final" - <*> mapping <|? "edges" - <*> mapping <|? "messages" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = State + <$> mapping <|? "viewers" + <*> mapping <|? "payload-view" + <*> mapping <|? "final" + <*> mapping <|? "edges" + <*> mapping <|? "messages" + <*> pure comment + <*> pure anchor -- | Wrapper for the `final` value of any node. @@ -86,11 +86,11 @@ module Workflow where } deriving Show instance FromYAML' StateViewers where - fromYAML (Mapping mapping comment anchor _) = StateViewers - <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label")) - <*> mapping <|? "viewers" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = StateViewers + <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label")) + <*> mapping <|? "viewers" + <*> pure comment + <*> pure anchor data Viewers = Viewers { @@ -105,8 +105,8 @@ module Workflow where <*> pure comment <*> pure anchor where toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode - toV m (Mapping [] _ _ _) = m - toV m (Mapping ((Scalar b _ _ _,v):xs) c a p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a p) + toV m (Mapping [] _ _ _ _) = m + toV m (Mapping ((Scalar b _ _ _,v):xs) c a md p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a md p) @@ -120,12 +120,12 @@ module Workflow where } deriving Show instance FromYAML' Label where - fromYAML (Mapping mapping comment anchor _) = Label - <$> mapping <|? "fallback" - <*> mapping <|? "fallback-lang" - <*> mapping <|? "translations" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = Label + <$> mapping <|? "fallback" + <*> mapping <|? "fallback-lang" + <*> mapping <|? "translations" + <*> pure comment + <*> pure anchor -- | Structure of an edge. @@ -143,17 +143,17 @@ module Workflow where } deriving Show instance FromYAML' Action where - fromYAML (Mapping mapping comment anchor _) = Action - <$> mapping <|? "mode" - <*> mapping <|? "source" - <*> mapping <|? "display-label" - <*> mapping <|? "actors" - <*> mapping <|? "view-actor" - <*> mapping <|? "viewers" - <*> mapping <|? "messages" - <*> mapping <|? "form" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = Action + <$> mapping <|? "mode" + <*> mapping <|? "source" + <*> mapping <|? "display-label" + <*> mapping <|? "actors" + <*> mapping <|? "view-actor" + <*> mapping <|? "viewers" + <*> mapping <|? "messages" + <*> mapping <|? "form" + <*> pure comment + <*> pure anchor data Message = Message { content :: Label, @@ -164,12 +164,12 @@ module Workflow where } deriving Show instance FromYAML' Message where - fromYAML (Mapping mapping comment anchor _) = Message - <$> mapping <| "content" - <*> mapping <|? "status" - <*> mapping <|? "viewers" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = Message + <$> mapping <| "content" + <*> mapping <|? "status" + <*> mapping <|? "viewers" + <*> pure comment + <*> pure anchor data Entry = Single Text diff --git a/app/YamlParser.hs b/app/YamlParser.hs index fa8694f..4a2543e 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -32,6 +32,7 @@ module YamlParser where } data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq) + data MergeData = MergeData {keys :: [Text], anchor :: AnchorData} deriving (Show, Eq) data YAMLNode = @@ -46,13 +47,14 @@ module YamlParser where content :: [(YAMLNode, YAMLNode)], comment :: [Comment], anchorData :: AnchorData, + mergeData :: [MergeData], -- keys of the maps merged into this mapping by "<<" pos :: Pos } | Sequence { children :: [YAMLNode], comment :: [Comment], anchorData :: AnchorData, pos :: Pos - } deriving Show + } deriving (Show, Eq) type Comment = Text @@ -83,7 +85,7 @@ module YamlParser where showTrace (EvPos event pos) $ case event of Y.Comment _ -> parseComment es >>= parseNode Y.SequenceStart anchor _ _ -> parseSequence es' anchor [] >>= \(seq, es'') -> return (Just seq, es'') - Y.MappingStart anchor _ _ -> parseMapping es' anchor [] >>= \(map, es'') -> return (Just map, es'') + Y.MappingStart anchor _ _ -> parseMapping es' anchor [] [] >>= \(map, es'') -> return (Just map, es'') Y.Scalar anchor _ _ text -> parseScalar anchor text pos >>= \scal -> return (Just scal, es') Y.Alias anchor -> parseAlias anchor >>= \a -> return (Just a, es') _ -> return (Nothing, es) -- error $ "Unexpected event: " ++ show event ++ " @" ++ show (posLine pos) @@ -104,33 +106,48 @@ module YamlParser where Just c -> parseSequence es' anchor (c : children) - parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> State ParseState (YAMLNode, EvStream) - parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content = showTrace (EvPos MappingEnd pos) $ do + parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> [MergeData] -> State ParseState (YAMLNode, EvStream) + parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content mergeData = showTrace (EvPos MappingEnd pos) $ do pState <- get let anchorData = maybe NoAnchor AnchorDef anchor - let map = Mapping (reverse content) [] anchorData pos + let map = Mapping (reverse content) [] anchorData mergeData pos let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) map pState.anchors put $ pState {anchors = anchors} return (map, es) - parseMapping es anchor content = do + parseMapping es anchor content mergeData = do (maybeKey, es') <- parseNode es case maybeKey of - Nothing -> parseMapping es' anchor content + Nothing -> parseMapping es' anchor content mergeData Just key -> do unless (isScalar key) . error $ "Key not a scalar: " ++ show key (maybeVal, es'') <- parseNode es' let val = fromJust maybeVal - 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 + if trace (show key.bytes ++ " is merge: " ++ show (isMerge key)) (isMerge key) then do + let (content', mergeKeys) = mergeMappings [] content val + let mergeData' = (MergeData mergeKeys key.anchorData) : mergeData + parseMapping es'' anchor content' mergeData' + else do + let content' = (key {comment = []}, val {comment = key.comment}) : content -- migrate comment to val to preserve it for the workflow data structure. alternative. don't use Data.Map for e.g. nodes and stages but a custom type and transfer it later. + parseMapping es'' anchor content' mergeData 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" + isMapping :: YAMLNode -> Bool + isMapping (Mapping {}) = True + isMapping _ = False + isSequence :: YAMLNode -> Bool + isSequence (Sequence {}) = True + isSequence _ = False + isMerge :: YAMLNode -> Bool + isMerge (Scalar b _ _ _) = unpack (decodeUtf8 b) == "<<" + mergeMappings :: [Text] -> [(YAMLNode, YAMLNode)] -> YAMLNode -> ([(YAMLNode, YAMLNode)], [Text]) + mergeMappings mergeKeys content (Mapping [] _ _ _ _) = (content, mergeKeys) + mergeMappings mergeKeys content m@(Mapping (x@(key, _):xs) _ _ _ _) + | isJust $ P.lookup key content = mergeMappings mergeKeys content m {content = xs} + | otherwise = mergeMappings ((decodeUtf8 key.bytes) : mergeKeys) (x : content) m {content = xs} + mergeMappings mergeKeys content (Sequence [] _ _ _) = (content, mergeKeys) + mergeMappings mergeKeys content s@(Sequence (m@(Mapping {}):xs) _ _ _) = mergeMappings mergeKeys' content' s {children = xs} where + (content', mergeKeys') = mergeMappings mergeKeys content m parseScalar :: Maybe Anchor -> Text -> Pos -> State ParseState YAMLNode @@ -162,7 +179,7 @@ module YamlParser where fromYAML y = Just <$> fromYAML y instance (Ord k, FromYAML' k, FromYAML' v) => FromYAML' (Map k v) where - fromYAML (Mapping c _ _ _) = fromList <$> mapM (\(a,b) -> (,) <$> fromYAML a <*> fromYAML b) c + fromYAML (Mapping c _ _ _ _) = fromList <$> mapM (\(a,b) -> (,) <$> fromYAML a <*> fromYAML b) c instance FromYAML' Text where fromYAML (Scalar bs _ _ _) = pure $ decodeUtf8 bs -- 2.39.2 From a4384f8bd13327791776d9763898c769a7fba586 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 03:50:43 +0200 Subject: [PATCH 4/9] propagate merge data to json --- app/Export.hs | 15 ++++++++++----- app/Workflow.hs | 35 ++++++++++++++++++++++++----------- app/YamlParser.hs | 2 +- 3 files changed, 35 insertions(+), 17 deletions(-) diff --git a/app/Export.hs b/app/Export.hs index 090c6a3..81d689d 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -12,7 +12,7 @@ module Export where -- import Data.YAML (Node (..)) import Data.YAML.Event (tagToText, Pos) import Data.Maybe (fromMaybe) - import YamlParser (YAMLNode (..), AnchorData (..)) + import YamlParser (YAMLNode (..), AnchorData (..), MergeData (..)) import Data.Aeson.Types (toJSONKeyText) --------------------------------------- @@ -58,15 +58,19 @@ module Export where toJSON (AnchorAlias a) = object ["type" .= String "alias", "name" .= a] toJSON NoAnchor = Null + instance ToJSON MergeData where + toJSON (MergeData keys anchor) = object ["keys" .= keys, "anchor" .= anchor] + instance ToJSON Pos instance ToJSON Message where - toJSON (Message content status viewers comment anchor) = object [ + toJSON (Message content status viewers comment anchor merge) = object [ "content" .= content, "status" .= status, "viewers" .= viewers, "comment" .= comment, - "anchor" .= anchor] + "anchor" .= anchor, + "merge" .= merge] instance ToJSON Viewers where toJSON (Viewers mappings comment anchor) = object [ @@ -75,12 +79,13 @@ module Export where "anchor" .= anchor ] instance ToJSON Label where - toJSON (Label fallback fallbackLang translations comment anchor) = object [ + toJSON (Label fallback fallbackLang translations comment anchor merge) = object [ "fallback" .= fallback, "fallback-lang" .= fallbackLang, "translations" .= translations, "comment" .= comment, - "anchor" .= anchor] + "anchor" .= anchor, + "merge" .= merge] instance ToJSON NodeData where toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where diff --git a/app/Workflow.hs b/app/Workflow.hs index 0446888..21c86f3 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -27,14 +27,16 @@ module Workflow where data Workflow = Workflow { nodes :: Map Text State, stages :: Maybe YAMLNode, - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Workflow where - fromYAML (Mapping mapping _ anchor _ pos) = Workflow + fromYAML (Mapping mapping _ anchor merge pos) = Workflow <$> mapping <| "nodes" <*> mapping <|? "stages" <*> pure anchor + <*> pure merge -- | Structure of a node. @@ -45,7 +47,8 @@ module Workflow where edges :: Maybe (Map Text Action), messages :: Maybe [Message], comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' State where @@ -57,6 +60,7 @@ module Workflow where <*> mapping <|? "messages" <*> pure comment <*> pure anchor + <*> pure merge -- | Wrapper for the `final` value of any node. @@ -82,7 +86,8 @@ module Workflow where name :: Either Label Text, viewers :: Maybe Viewers, comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' StateViewers where @@ -91,12 +96,13 @@ module Workflow where <*> mapping <|? "viewers" <*> pure comment <*> pure anchor + <*> pure merge data Viewers = Viewers { viewers :: [Map Text YAMLNode], comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData } deriving Show instance FromYAML' Viewers where @@ -116,7 +122,8 @@ module Workflow where fallbackLang :: Maybe Text, translations :: Maybe YAMLNode, comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Label where @@ -126,6 +133,7 @@ module Workflow where <*> mapping <|? "translations" <*> pure comment <*> pure anchor + <*> pure merge -- | Structure of an edge. @@ -138,8 +146,9 @@ module Workflow where viewers :: Maybe Viewers, messages :: Maybe [Message], form :: Maybe YAMLNode, - comment :: [Comment], - anchor :: AnchorData + comment :: [Comment], + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Action where @@ -154,13 +163,15 @@ module Workflow where <*> mapping <|? "form" <*> pure comment <*> pure anchor + <*> pure merge data Message = Message { content :: Label, status :: Maybe Text, viewers :: Maybe Viewers, comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Message where @@ -170,6 +181,7 @@ module Workflow where <*> mapping <|? "viewers" <*> pure comment <*> pure anchor + <*> pure merge data Entry = Single Text @@ -203,12 +215,13 @@ module Workflow where buildData :: Workflow -> GraphData buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor, - viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor)) Nothing [] NoAnchor, + viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor [])) Nothing [] NoAnchor [], payload = Nothing, edges = Nothing, messages = Nothing, comment = [], - anchor = NoAnchor}) wf.nodes + anchor = NoAnchor, + merge = []}) wf.nodes analyse :: Text -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData) analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed) extract :: State -> Map Text Entry diff --git a/app/YamlParser.hs b/app/YamlParser.hs index 4a2543e..437ed35 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -122,7 +122,7 @@ module YamlParser where unless (isScalar key) . error $ "Key not a scalar: " ++ show key (maybeVal, es'') <- parseNode es' let val = fromJust maybeVal - if trace (show key.bytes ++ " is merge: " ++ show (isMerge key)) (isMerge key) then do + if isMerge key then do let (content', mergeKeys) = mergeMappings [] content val let mergeData' = (MergeData mergeKeys key.anchorData) : mergeData parseMapping es'' anchor content' mergeData' -- 2.39.2 From d77e73f737032f3e3be1bfc29035c000646e0175 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 04:51:06 +0200 Subject: [PATCH 5/9] unpack text before output --- app/Main.hs | 9 +++++---- app/Workflow.hs | 7 +++++++ app/YamlParser.hs | 15 ++++++++++----- 3 files changed, 22 insertions(+), 9 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7d17e9a..1c8fa64 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,7 +20,7 @@ module Main where import Index (Index, Entry (Entry), getDefDescription, getInstDescription, getEntryByFile) import Data.Char (isSpace) - 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 Control.Monad (forM_) @@ -80,6 +80,7 @@ module Main where generateJSON args = do -- print $ head args -- print $ last args + putStrLn $ "reading " ++ head args ++ "..." content <- BS.readFile (head args) let decoded = decodeWithComments1Strict content :: Either (Pos, String) Workflow if isLeft decoded then error (show $ fromLeft undefined decoded) else do @@ -91,7 +92,7 @@ module Main where encodeFile (last args) $ buildData yaml - blackList = ["patch.yaml"] -- files not to parse when parsing the entire directory + blackList = ["patch.yaml", "theses.yaml", "master-practical-training.yaml"] -- files not to parse when parsing the entire directory -- | Processes all workflow definitions within the given directory (1) and writes the output files @@ -125,9 +126,9 @@ module Main where description = if isJust description1 then description1 else description2 url = snd x format = dropWhileEnd isSpace . map (\y -> if y == '\n' then ' ' else y) - newContent = (if null xs then "" else ",\n") ++ "{\n\"name\": \"" ++ format (show $ fromMaybe (pack $ snd x) name) + newContent = (if null xs then "" else ",\n") ++ "{\n\"name\": \"" ++ format (unpack $ fromMaybe (pack $ snd x) name) ++ "\",\n\"description\": \"" - ++ format (show $ fromMaybe (pack "") description) ++ "\",\n\"url\": \"" ++ url ++ "\"}" + ++ format (unpack $ fromMaybe (pack "") description) ++ "\",\n\"url\": \"" ++ url ++ "\"}" in writeIndex index xs (newContent ++ content) decodeIndex :: FilePath -> IO Index decodeIndex path = do diff --git a/app/Workflow.hs b/app/Workflow.hs index 21c86f3..42423fb 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -134,6 +134,13 @@ module Workflow where <*> pure comment <*> pure anchor <*> pure merge + fromYAML (Scalar bytes comment anchor _) = Label + <$> pure (Just . decodeUtf8 $ bytes) + <*> pure (Just . pack $ "de-de-formal") + <*> pure Nothing + <*> pure comment + <*> pure anchor + <*> pure [] -- | Structure of an edge. diff --git a/app/YamlParser.hs b/app/YamlParser.hs index 437ed35..982ce3b 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -63,6 +63,11 @@ module YamlParser where parse ((Right (EvPos (DocumentEnd _) pos)):_) = get >>= \pState -> return $ if length pState.rootNodes == 1 then head pState.rootNodes else Sequence pState.rootNodes [] NoAnchor pos + parse [] = get >>= \pState -> return $ if length pState.rootNodes == 1 + then head pState.rootNodes + else Sequence pState.rootNodes [] NoAnchor undefined + parse ((Right (EvPos StreamStart _)):es) = parseComment es >>= parse + parse ((Right (EvPos (DocumentStart _) _)):es) = parse es parse es = do (root, es') <- parseNode es pState <- get @@ -78,8 +83,8 @@ module YamlParser where parseNode :: EvStream -> State ParseState (Maybe YAMLNode, EvStream) - parseNode [] = error "Unexpected eof" - parseNode ((Left _):es) = error "Failed to parse" + parseNode [] = trace "Unexpected eof" $ return (Nothing, []) + parseNode ((Left (p,s)):es) = trace ("Failed to parse: " ++ show s ++ " @ line " ++ show p.posLine) $ parseNode es parseNode es@((Right (EvPos event pos)):es') = do pState <- get showTrace (EvPos event pos) $ case event of @@ -197,10 +202,10 @@ module YamlParser where decodeWithComments1 :: FromYAML' v => BS.L.ByteString -> Either (Pos, String) v decodeWithComments1 input = do let events = parseEvents input - let mainEvents = validHead events - unless (isJust mainEvents) . error $ "Missing DocumentStart event" + -- let mainEvents = validHead events + -- unless (isJust mainEvents) . error $ "Missing DocumentStart event" let initState = PState [] empty [] - let content = evalState (parse $ fromJust mainEvents) initState + let content = evalState (parse events) initState parseEither . fromYAML $ content where validHead :: EvStream -> Maybe EvStream -- 2.39.2 From 695e7a4a51c78f2127396745cdbece2c96cb78cf Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sat, 1 Jul 2023 02:57:34 +0200 Subject: [PATCH 6/9] adjusted frontend to new data structure --- app/Export.hs | 56 +++++++++++++++++++++++++++-------------------- app/Workflow.hs | 45 +++++++++++++++++++++++++++---------- app/YamlParser.hs | 8 +++++-- editor.js | 28 ++++++++++++------------ workflow.js | 2 +- 5 files changed, 86 insertions(+), 53 deletions(-) diff --git a/app/Export.hs b/app/Export.hs index 81d689d..ec9b6f0 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -7,7 +7,7 @@ module Export where import Data.Aeson import Data.Map hiding (fromList) import Data.Vector hiding ((!), (++)) - import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..), Message(..), Label(..), Viewers (..)) + import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..), Message(..), Label(..), Viewers (..), Actors (Actors)) import Data.Text (Text, pack) -- import Data.YAML (Node (..)) import Data.YAML.Event (tagToText, Pos) @@ -24,34 +24,35 @@ module Export where toJSON (Single s) = toJSON s toJSON (Msg m) = toJSON m toJSON (Vie v) = toJSON v + toJSON (Act a) = toJSON a 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 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 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] @@ -78,6 +79,13 @@ module Export where "comment" .= comment, "anchor" .= anchor ] + + instance ToJSON Actors where + toJSON (Actors (Viewers mappings comment anchor)) = object [ + "actors" .= mappings, + "comment" .= comment, + "anchor" .= anchor + ] instance ToJSON Label where toJSON (Label fallback fallbackLang translations comment anchor merge) = object [ "fallback" .= fallback, diff --git a/app/Workflow.hs b/app/Workflow.hs index 42423fb..07aec96 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -8,15 +8,20 @@ module Workflow where ----------------Imports---------------- - import Data.YAML hiding (Scalar, Mapping, Sequence) + import Data.YAML hiding (Scalar, Mapping, Sequence, encode) + import Data.Aeson(encode, ToJSON, ToJSONKey (toJSONKey)) import Control.Applicative hiding (empty) import GHC.Generics (Generic) import Data.Map import Data.Maybe (fromMaybe, isNothing, fromJust) - import Data.Text (Text, pack) + import Data.Text (Text, pack, unpack) import YamlParser import Data.Text.Encoding (decodeUtf8, encodeUtf8) + import qualified Data.Text.Lazy.Encoding as TL + import qualified Data.Text.Lazy as TL import Debug.Trace (trace) + import Data.Yaml (ToJSON(toJSON)) + import Data.Aeson.Types (toJSONKeyText) --------------------------------------- @@ -65,14 +70,14 @@ module Workflow where -- | Wrapper for the `final` value of any node. data Final = Final { - final :: String, + final :: Text, comment :: [Comment], anchor :: AnchorData } deriving Show instance FromYAML' Final where fromYAML (Scalar bytes comment anchor _) = Final - <$> pure (show $ decodeUtf8 bytes) + <$> pure (decodeUtf8 bytes) <*> pure comment <*> pure anchor @@ -105,14 +110,29 @@ module Workflow where anchor :: AnchorData } deriving Show + newtype Actors = Actors Viewers deriving Show + instance FromYAML' Viewers where fromYAML (Sequence seq comment anchor _) = Viewers <$> pure (Prelude.map (toV empty) seq) <*> pure comment <*> pure anchor where - toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode - toV m (Mapping [] _ _ _ _) = m - toV m (Mapping ((Scalar b _ _ _,v):xs) c a md p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a md p) + toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode + toV m (Mapping [] _ _ _ _) = m + toV m (Mapping ((Scalar b _ _ _,v):xs) c a md p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a md p) + + instance FromYAML' Actors where + fromYAML x = Actors <$> fromYAML x + + instance ToJSON YAMLNode where + toJSON (Scalar b _ _ _) = toJSON $ decodeUtf8 b + toJSON (Mapping ct _ _ _ _) = toJSON $ fromList ct + toJSON (Sequence ch _ _ _) = toJSON ch + + instance ToJSONKey YAMLNode where + toJSONKey = toJSONKeyText display where + display :: YAMLNode -> Text + display (Scalar bytes _ _ _) = decodeUtf8 bytes @@ -148,7 +168,7 @@ module Workflow where mode :: Maybe Text, source :: Maybe Text, name :: Maybe Label, - actors :: Maybe Viewers, + actors :: Maybe Actors, viewActor :: Maybe Viewers, viewers :: Maybe Viewers, messages :: Maybe [Message], @@ -194,6 +214,7 @@ module Workflow where data Entry = Single Text | Msg Message | Vie Viewers + | Act Actors | Dict (Map Text YAMLNode) | List [Entry] | Val YAMLNode deriving Show @@ -236,7 +257,7 @@ module Workflow where ("comment", List $ Prelude.map Single s.comment), ("anchor", Single . pack . show $ s.anchor), ("viewers", Vie viewers), - ("final", Single $ pack final), + ("final", Single final), ("messages", List $ Prelude.map Msg messages), ("payload", payload)] where (name, viewers) = case s.viewers of @@ -251,7 +272,7 @@ module Workflow where payload = maybe (Val (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0))) Dict s.payload updateEdges :: Text -> Maybe (Map Text Action) -> EdgeData -> EdgeData updateEdges _ Nothing e = e - updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (pack $ show k ++ "_@_" ++ show targetID) (newData k action targetID) eData) e edges + updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (pack $ unpack k ++ "_@_" ++ unpack 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), @@ -259,7 +280,7 @@ module Workflow where ("source", Single source), ("target", Single targetID), ("mode", Single mode), - ("actors", Vie actors), + ("actors", Act actors), ("viewers", Vie viewers), ("view-actor", Vie viewActor), ("messages", List $ Prelude.map Msg messages), @@ -271,7 +292,7 @@ module Workflow where Just x -> x source = fromMaybe initID a.source mode = fromMaybe "" a.mode - actors = fromMaybe (Viewers [] [] NoAnchor) a.actors + actors = fromMaybe (Actors $ Viewers [] [] NoAnchor) a.actors viewers = fromMaybe (Viewers [] [] NoAnchor) a.viewers viewActor = fromMaybe (Viewers [] [] NoAnchor) a.viewActor messages = fromMaybe [] a.messages diff --git a/app/YamlParser.hs b/app/YamlParser.hs index 982ce3b..db7513d 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -31,8 +31,8 @@ module YamlParser where comments :: [Comment] -- YAML comment queue for the next node. } - data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq) - data MergeData = MergeData {keys :: [Text], anchor :: AnchorData} deriving (Show, Eq) + data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq, Ord) + data MergeData = MergeData {keys :: [Text], anchor :: AnchorData} deriving (Show, Eq, Ord) data YAMLNode = @@ -56,6 +56,10 @@ module YamlParser where pos :: Pos } deriving (Show, Eq) + instance Ord YAMLNode where + (Scalar b1 _ _ _) <= (Scalar b2 _ _ _) = b1 <= b2 + _ <= _ = undefined + type Comment = Text diff --git a/editor.js b/editor.js index 3de5bc7..d9d15d3 100644 --- a/editor.js +++ b/editor.js @@ -682,8 +682,8 @@ function prepareWorkflow() { state.stateData.messages.forEach(msg => messages.push(new Message(msg))); state.stateData.messages = messages; var viewers = []; - state.stateData.viewers.forEach(v => viewers.push(new Role(v))); - state.stateData.viewers = viewers; + state.stateData.viewers.viewers.forEach(v => viewers.push(new Role(v))); + state.stateData.viewers.viewers = viewers; state.stateData.payload = new Payload(state.stateData.payload); nodeIndex.add(state.id, state.name); }) @@ -693,19 +693,19 @@ function prepareWorkflow() { action.actionData.messages.forEach(msg => messages.push(new Message(msg))); action.actionData.messages = messages; var viewers = []; - action.actionData.viewers.forEach(v => viewers.push(new Role(v))); - action.actionData.viewers = viewers; + action.actionData.viewers.viewers.forEach(v => viewers.push(new Role(v))); + action.actionData.viewers.viewers = viewers; var actors = []; - action.actionData.actors.forEach(v => actors.push(new Role(v))); - action.actionData.actors = actors; + action.actionData.actors.actors.forEach(v => actors.push(new Role(v))); + action.actionData.actors.actors = actors; var viewActors = []; - action.actionData['actor Viewers'].forEach(v => viewActors.push(new Role(v))); - action.actionData['actor Viewers'] = viewActors; + action.actionData['actor Viewers'].viewers.forEach(v => viewActors.push(new Role(v))); + action.actionData['actor Viewers'].viewers = viewActors; action.actionData.form = new Payload(action.actionData.form); actionIndex.add(action.id, action.name); }) - workflow.actions.forEach(act => act.actionData.actors.forEach(a => { + workflow.actions.forEach(act => act.actionData.actors.actors.forEach(a => { var includes = false; actors.forEach(actor => includes = includes || equalRoles(a, actor)); (!includes) && actors.push(a); @@ -725,10 +725,10 @@ function prepareWorkflow() { //Identify all viewers of every action workflow.actions.forEach(act => { - if (act.actionData.viewers.length === 0) { + if (act.actionData.viewers.viewers.length === 0) { viewableByAll.push(act.actionData); } else { - act.actionData.viewers.forEach(v => { + act.actionData.viewers.viewers.forEach(v => { var includes = false; viewers.forEach(viewer => includes = includes || equalRoles(v, viewer)); (!includes) && viewers.push(v); @@ -747,7 +747,7 @@ function prepareWorkflow() { } else if (st.stateData.viewers.length === 0) { viewableByAll.push(st.stateData); } else { - st.stateData.viewers.forEach(v => { + st.stateData.viewers.viewers.forEach(v => { var includes = false; viewers.forEach(viewer => includes = includes || equalRoles(v, viewer)); (!includes) && viewers.push(v); @@ -867,8 +867,8 @@ function getNodeColour(node) { || highlightedSources.includes(node.id) || highlightedTargets.includes(node.id) var alpha = standard ? 'ff' : '55'; var isSelected = selection === node || rightSelection === node; - if (node.stateData && node.stateData.final !== 'False' && node.stateData.final !== '') { - if (node.stateData.final === 'True' || node.stateData.final === 'ok') { + if (node.stateData && node.stateData.final !== 'false' && node.stateData.final !== '') { + if (node.stateData.final === 'true' || node.stateData.final === 'ok') { return (isSelected ? '#3ac713' : '#31a810') + alpha; } else if (node.stateData.final === 'not-ok') { return (isSelected ? '#ec4e7b' : '#e7215a') + alpha; diff --git a/workflow.js b/workflow.js index 597d0f3..5520827 100644 --- a/workflow.js +++ b/workflow.js @@ -29,7 +29,7 @@ class Message { this.translations = content.translations; this.status = json.status; this.viewers = []; - json.viewers.forEach(v => this.viewers.push(new Role(v))); + json.viewers.viewers.forEach(v => this.viewers.push(new Role(v))); } -- 2.39.2 From 3d4abef08daef51b15a0ddfff449eff9bc87fcab Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 14 Jul 2023 03:36:10 +0200 Subject: [PATCH 7/9] frontend visualisation of anchors & comments --- .gitignore | 3 ++- editor.js | 20 +++++---------- workflow.js | 74 ++++++++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 74 insertions(+), 23 deletions(-) diff --git a/.gitignore b/.gitignore index fcd8457..6eef855 100644 --- a/.gitignore +++ b/.gitignore @@ -2,4 +2,5 @@ CHANGELOG.md test.json server.py -/workflows \ No newline at end of file +/workflows +/spaß \ No newline at end of file diff --git a/editor.js b/editor.js index d9d15d3..73f24b5 100644 --- a/editor.js +++ b/editor.js @@ -563,9 +563,11 @@ function generatePanelContent(selection) { viewerList.appendChild(v); }); children.push(viewerList); + } else if (content instanceof Roles) { + content.format().forEach(child => children.push(child)); } else { var p = document.createElement('p'); - var text = document.createTextNode(JSON.stringify(data[key])); + var text = document.createTextNode((key == 'comment') ? data[key].join(' ') : JSON.stringify(data[key])); p.appendChild(text); children.push(p); } @@ -681,9 +683,7 @@ function prepareWorkflow() { var messages = []; state.stateData.messages.forEach(msg => messages.push(new Message(msg))); state.stateData.messages = messages; - var viewers = []; - state.stateData.viewers.viewers.forEach(v => viewers.push(new Role(v))); - state.stateData.viewers.viewers = viewers; + state.stateData.viewers = new Viewers(state.stateData.viewers); state.stateData.payload = new Payload(state.stateData.payload); nodeIndex.add(state.id, state.name); }) @@ -692,15 +692,9 @@ function prepareWorkflow() { var messages = []; action.actionData.messages.forEach(msg => messages.push(new Message(msg))); action.actionData.messages = messages; - var viewers = []; - action.actionData.viewers.viewers.forEach(v => viewers.push(new Role(v))); - action.actionData.viewers.viewers = viewers; - var actors = []; - action.actionData.actors.actors.forEach(v => actors.push(new Role(v))); - action.actionData.actors.actors = actors; - var viewActors = []; - action.actionData['actor Viewers'].viewers.forEach(v => viewActors.push(new Role(v))); - action.actionData['actor Viewers'].viewers = viewActors; + action.actionData.viewers = new Viewers(action.actionData.viewers); + action.actionData.actors = new Actors(action.actionData.actors); + action.actionData['actor Viewers'] = new Viewers(action.actionData['actor Viewers']); action.actionData.form = new Payload(action.actionData.form); actionIndex.add(action.id, action.name); }) diff --git a/workflow.js b/workflow.js index 5520827..5cde275 100644 --- a/workflow.js +++ b/workflow.js @@ -20,6 +20,66 @@ class Role { } } +class Roles { + constructor(json, roleName) { + this.roleName = roleName + this.anchor = json.anchor && new Anchor(json.anchor) + this[roleName] = []; + for (const role of json[roleName]) + this[roleName].push(new Role(role)); + this.comment = json.comment; + } + + format() { + var r = document.createElement('h4'); + var roles = document.createTextNode('Roles'); + r.appendChild(roles); + var rolesList = document.createElement('ul'); + this[this.roleName].forEach(r => { + var role = document.createElement('li'); + role.appendChild(document.createTextNode(r.name)); + rolesList.appendChild(role); + }); + var result = []; + if (this.comment.length > 0) { + var c = document.createElement('h4'); + c.innerText = 'Comment'; + var comment = document.createElement('p'); + comment.innerText = this.comment.join(' '); + result.push(c, comment); + } + if (this.anchor) { + var a = document.createElement('h4'); + a.appendChild(this.anchor.format()); + result.push(a); + } else result.push(r) + result.push(rolesList); + return result; + } +} + +class Viewers extends Roles { + constructor(json) { + super(json, 'viewers'); + } +} + +class Actors extends Roles { + constructor(json) { + super(json, 'actors'); + } +} +class Anchor { + constructor(json) { + this.name = json.name; + this.type = json.type; + } + + format() { + return document.createTextNode(`${this.type == 'alias' ? '*' : '&'}${this.name}`); + } +} + class Message { constructor(json) { @@ -28,8 +88,7 @@ class Message { this.fallbackLang = content['fallback-lang']; this.translations = content.translations; this.status = json.status; - this.viewers = []; - json.viewers.viewers.forEach(v => this.viewers.push(new Role(v))); + this.viewers = new Viewers(json.viewers); } @@ -37,19 +96,16 @@ class Message { var v = document.createElement('h3'); var viewers = document.createTextNode('Viewers'); v.appendChild(viewers); - var viewerList = document.createElement('ul'); - this.viewers.forEach(v => { - var viewer = document.createElement('li'); - viewer.appendChild(document.createTextNode(v.name)); - viewerList.appendChild(viewer); - }); + var viewerList = this.viewers.format(); var h = document.createElement('h3'); var heading = document.createTextNode('Status'); h.appendChild(heading); var p = document.createElement('p'); var text = document.createTextNode(this.status); p.appendChild(text); - var result = [v, viewerList, h, p]; + var result = [v]; + result = result.concat(viewerList); + result.push(h, p); h = document.createElement('h3'); heading = document.createTextNode(this.fallbackLang); h.appendChild(heading); -- 2.39.2 From 4682abb129d9d50700dde15c24d7fbef22effc2b Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 23 Jul 2023 16:05:17 +0200 Subject: [PATCH 8/9] adjusted blacklist --- app/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 1c8fa64..228cb5a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -41,7 +41,7 @@ module Main where main :: IO () main = getArgs >>= process >>= finish where process :: [String] -> IO Bool - process [path] = runParser path >> return True + process [path] = printEvents path >> runParser path >> return True process args@[_, _] = generateJSON args >> return False process args@["--all", src, to] = processDirectory src to >> return False process _ = print "Please provide (1) a source and (2) a target file or provide '--all' and (1) a source and (2) a target directory" >> return True @@ -52,7 +52,7 @@ module Main where printEvents :: FilePath -> IO () printEvents path = do input <- BS.L.readFile path - forM_ (take 700 $ parseEvents input) $ \ev -> case ev of + forM_ (parseEvents input) $ \ev -> case ev of Left _ -> error "Failed to parse" Right event -> putStrLn (show (eEvent event) ++ " @" ++ show (posLine $ ePos event)) @@ -92,7 +92,7 @@ module Main where encodeFile (last args) $ buildData yaml - blackList = ["patch.yaml", "theses.yaml", "master-practical-training.yaml"] -- files not to parse when parsing the entire directory + blackList = ["patch.yaml"] -- files not to parse when parsing the entire directory -- | Processes all workflow definitions within the given directory (1) and writes the output files -- 2.39.2 From 058cf32d18e7c80d750f52e1b58d59641b10eac6 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Thu, 24 Aug 2023 04:35:23 +0200 Subject: [PATCH 9/9] removed other yaml library --- app/Workflow.hs | 3 +-- workflow-visualiser.cabal | 1 - 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/app/Workflow.hs b/app/Workflow.hs index 07aec96..d356d95 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -9,7 +9,7 @@ module Workflow where ----------------Imports---------------- import Data.YAML hiding (Scalar, Mapping, Sequence, encode) - import Data.Aeson(encode, ToJSON, ToJSONKey (toJSONKey)) + import Data.Aeson(encode, ToJSON (toJSON), ToJSONKey (toJSONKey)) import Control.Applicative hiding (empty) import GHC.Generics (Generic) import Data.Map @@ -20,7 +20,6 @@ module Workflow where import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Text.Lazy as TL import Debug.Trace (trace) - import Data.Yaml (ToJSON(toJSON)) import Data.Aeson.Types (toJSONKeyText) --------------------------------------- diff --git a/workflow-visualiser.cabal b/workflow-visualiser.cabal index 5c5f306..efbd5a0 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -33,7 +33,6 @@ executable workflow-visualiser -- LANGUAGE extensions used by modules in this package. -- other-extensions: build-depends: base ^>=4.16.3.0, - yaml >= 0.11.11.0, HsYAML, aeson >= 2.1.2.0, bytestring, -- 2.39.2