Hsyaml #3
@ -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,
|
||||
|
||||
22
app/Index.hs
22
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";
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user