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

WIP: preserving comments & anchors

Browse Source
This commit is contained in:
David Mosbach 2023-06-30 00:35:55 +02:00
parent 4c24eab8c7
commit a5a89674a7
6 changed files with 487 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
app/Export.hs
View File

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

59
app/Index.hs
View File

@ -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

55
app/Main.hs
View File

@ -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

235
app/Workflow.hs
View File

@ -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
---------------------------------------

199
app/YamlParser.hs Normal file
View File

@ -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]

7
workflow-visualiser.cabal
View File

@ -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