lmu/uni2work.workflows.visualiser
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge mappings after merge key <<

Browse Source
This commit is contained in:
David Mosbach 2023-06-30 03:39:33 +02:00
parent f10798511e
commit 06b690c5a1
4 changed files with 92 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
app/Export.hs
View File

@ -35,12 +35,12 @@ module Export where
"anchor" .= a, "anchor" .= a,
"position" .= p "position" .= p
] ]
toJSON (Mapping ct cm a p) = object [ toJSON (Mapping ct cm a md p) = object [
"content" .= ct, "content" .= ct,
"comment" .= cm, "comment" .= cm,
"anchor" .= a, "anchor" .= a,
"position" .= p "position" .= p
] ]
toJSON (Sequence ch cm a p) = object [ toJSON (Sequence ch cm a p) = object [
"content" .= ch, "content" .= ch,
"comment" .= cm, "comment" .= cm,

22
app/Index.hs
View File

@ -25,13 +25,13 @@ module Index where
} deriving Show } deriving Show
instance FromYAML' Entry where instance FromYAML' Entry where
fromYAML (Mapping mapping _ _ _) = Entry fromYAML (Mapping mapping _ _ _ _) = Entry
<$> mapping <| "graph-file" <$> mapping <| "graph-file"
<*> mapping <|? "category" <*> mapping <|? "category"
<*> mapping <|? "definition-scope" <*> mapping <|? "definition-scope"
<*> mapping <|? "definition-description" <*> mapping <|? "definition-description"
<*> mapping <|? "instance-description" <*> mapping <|? "instance-description"
<*> mapping <| "instances" <*> mapping <| "instances"
-- parseJSON _ = error "Unexpected yaml" -- parseJSON _ = error "Unexpected yaml"
type Title = Text type Title = Text
@ -44,10 +44,10 @@ module Index where
} deriving Show } deriving Show
instance FromYAML' Description where instance FromYAML' Description where
fromYAML (Mapping mapping _ _ _) = Description fromYAML (Mapping mapping _ _ _ _) = Description
<$> mapping <|? "fallback-lang" <$> mapping <|? "fallback-lang"
<*> mapping <| "fallback" <*> mapping <| "fallback"
<*> mapping <| "translations" <*> mapping <| "translations"
english = "en-eu"; english = "en-eu";

84
app/Workflow.hs
View File

@ -31,10 +31,10 @@ module Workflow where
} deriving Show } deriving Show
instance FromYAML' Workflow where instance FromYAML' Workflow where
fromYAML (Mapping mapping _ anchor pos) = Workflow fromYAML (Mapping mapping _ anchor _ pos) = Workflow
<$> mapping <| "nodes" <$> mapping <| "nodes"
<*> mapping <|? "stages" <*> mapping <|? "stages"
<*> pure anchor <*> pure anchor
-- | Structure of a node. -- | Structure of a node.
@ -49,14 +49,14 @@ module Workflow where
} deriving Show } deriving Show
instance FromYAML' State where instance FromYAML' State where
fromYAML (Mapping mapping comment anchor _) = State fromYAML (Mapping mapping comment anchor merge _) = State
<$> mapping <|? "viewers" <$> mapping <|? "viewers"
<*> mapping <|? "payload-view" <*> mapping <|? "payload-view"
<*> mapping <|? "final" <*> mapping <|? "final"
<*> mapping <|? "edges" <*> mapping <|? "edges"
<*> mapping <|? "messages" <*> mapping <|? "messages"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
-- | Wrapper for the `final` value of any node. -- | Wrapper for the `final` value of any node.
@ -86,11 +86,11 @@ module Workflow where
} deriving Show } deriving Show
instance FromYAML' StateViewers where instance FromYAML' StateViewers where
fromYAML (Mapping mapping comment anchor _) = StateViewers fromYAML (Mapping mapping comment anchor merge _) = StateViewers
<$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label")) <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label"))
<*> mapping <|? "viewers" <*> mapping <|? "viewers"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
data Viewers = Viewers { data Viewers = Viewers {
@ -105,8 +105,8 @@ module Workflow where
<*> pure comment <*> pure comment
<*> pure anchor where <*> pure anchor where
toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode
toV m (Mapping [] _ _ _) = m 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 ((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 } deriving Show
instance FromYAML' Label where instance FromYAML' Label where
fromYAML (Mapping mapping comment anchor _) = Label fromYAML (Mapping mapping comment anchor merge _) = Label
<$> mapping <|? "fallback" <$> mapping <|? "fallback"
<*> mapping <|? "fallback-lang" <*> mapping <|? "fallback-lang"
<*> mapping <|? "translations" <*> mapping <|? "translations"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
-- | Structure of an edge. -- | Structure of an edge.
@ -143,17 +143,17 @@ module Workflow where
} deriving Show } deriving Show
instance FromYAML' Action where instance FromYAML' Action where
fromYAML (Mapping mapping comment anchor _) = Action fromYAML (Mapping mapping comment anchor merge _) = Action
<$> mapping <|? "mode" <$> mapping <|? "mode"
<*> mapping <|? "source" <*> mapping <|? "source"
<*> mapping <|? "display-label" <*> mapping <|? "display-label"
<*> mapping <|? "actors" <*> mapping <|? "actors"
<*> mapping <|? "view-actor" <*> mapping <|? "view-actor"
<*> mapping <|? "viewers" <*> mapping <|? "viewers"
<*> mapping <|? "messages" <*> mapping <|? "messages"
<*> mapping <|? "form" <*> mapping <|? "form"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
data Message = Message { data Message = Message {
content :: Label, content :: Label,
@ -164,12 +164,12 @@ module Workflow where
} deriving Show } deriving Show
instance FromYAML' Message where instance FromYAML' Message where
fromYAML (Mapping mapping comment anchor _) = Message fromYAML (Mapping mapping comment anchor merge _) = Message
<$> mapping <| "content" <$> mapping <| "content"
<*> mapping <|? "status" <*> mapping <|? "status"
<*> mapping <|? "viewers" <*> mapping <|? "viewers"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
data Entry = Single Text data Entry = Single Text

49
app/YamlParser.hs
View File

@ -32,6 +32,7 @@ module YamlParser where
} }
data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq) data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq)
data MergeData = MergeData {keys :: [Text], anchor :: AnchorData} deriving (Show, Eq)
data YAMLNode = data YAMLNode =
@ -46,13 +47,14 @@ module YamlParser where
content :: [(YAMLNode, YAMLNode)], content :: [(YAMLNode, YAMLNode)],
comment :: [Comment], comment :: [Comment],
anchorData :: AnchorData, anchorData :: AnchorData,
mergeData :: [MergeData], -- keys of the maps merged into this mapping by "<<"
pos :: Pos pos :: Pos
} | Sequence { } | Sequence {
children :: [YAMLNode], children :: [YAMLNode],
comment :: [Comment], comment :: [Comment],
anchorData :: AnchorData, anchorData :: AnchorData,
pos :: Pos pos :: Pos
} deriving Show } deriving (Show, Eq)
type Comment = Text type Comment = Text
@ -83,7 +85,7 @@ module YamlParser where
showTrace (EvPos event pos) $ case event of showTrace (EvPos event pos) $ case event of
Y.Comment _ -> parseComment es >>= parseNode Y.Comment _ -> parseComment es >>= parseNode
Y.SequenceStart anchor _ _ -> parseSequence es' anchor [] >>= \(seq, es'') -> return (Just seq, es'') 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.Scalar anchor _ _ text -> parseScalar anchor text pos >>= \scal -> return (Just scal, es')
Y.Alias anchor -> parseAlias anchor >>= \a -> return (Just a, es') Y.Alias anchor -> parseAlias anchor >>= \a -> return (Just a, es')
_ -> return (Nothing, es) -- error $ "Unexpected event: " ++ show event ++ " @" ++ show (posLine pos) _ -> 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) Just c -> parseSequence es' anchor (c : children)
parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> State ParseState (YAMLNode, EvStream) parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> [MergeData] -> State ParseState (YAMLNode, EvStream)
parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content = showTrace (EvPos MappingEnd pos) $ do parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content mergeData = showTrace (EvPos MappingEnd pos) $ do
pState <- get pState <- get
let anchorData = maybe NoAnchor AnchorDef anchor 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 let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) map pState.anchors
put $ pState {anchors = anchors} put $ pState {anchors = anchors}
return (map, es) return (map, es)
parseMapping es anchor content = do parseMapping es anchor content mergeData = do
(maybeKey, es') <- parseNode es (maybeKey, es') <- parseNode es
case maybeKey of case maybeKey of
Nothing -> parseMapping es' anchor content Nothing -> parseMapping es' anchor content mergeData
Just key -> do Just key -> do
unless (isScalar key) . error $ "Key not a scalar: " ++ show key unless (isScalar key) . error $ "Key not a scalar: " ++ show key
(maybeVal, es'') <- parseNode es' (maybeVal, es'') <- parseNode es'
let val = fromJust maybeVal 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 if trace (show key.bytes ++ " is merge: " ++ show (isMerge key)) (isMerge key) then do
when (not (null key.comment) && (safeHead . unpack . head $ key.comment) == '#' ) $ trace ("Migr to: " ++ show (snd . head $ content').comment) return() let (content', mergeKeys) = mergeMappings [] content val
parseMapping es'' anchor content' where 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 :: YAMLNode -> Bool
isScalar (Scalar {}) = True isScalar (Scalar {}) = True
isScalar _ = False isScalar _ = False
safeHead [] = ' ' -- TODO remove those isMapping :: YAMLNode -> Bool
safeHead (x:xs) = x isMapping (Mapping {}) = True
showType (Scalar {}) = "Scalar" isMapping _ = False
showType (Mapping {}) = "Mapping" isSequence :: YAMLNode -> Bool
showType (Sequence {}) = "Sequence" 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 parseScalar :: Maybe Anchor -> Text -> Pos -> State ParseState YAMLNode
@ -162,7 +179,7 @@ module YamlParser where
fromYAML y = Just <$> fromYAML y fromYAML y = Just <$> fromYAML y
instance (Ord k, FromYAML' k, FromYAML' v) => FromYAML' (Map k v) where 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 instance FromYAML' Text where
fromYAML (Scalar bs _ _ _) = pure $ decodeUtf8 bs fromYAML (Scalar bs _ _ _) = pure $ decodeUtf8 bs