From ff34ce7713d43be2e3b9c1ae1401ba605030aae8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 19 Jun 2023 02:31:49 +0200 Subject: [PATCH] parser preserves anchors & comments --- app/Export.hs | 58 +++++++++- app/Index.hs | 60 +++++----- app/Main.hs | 57 +++++++-- app/Parser.hs | 224 +++++++++++++++++++++++++++++++++++ app/Workflow.hs | 237 +++++++++++++++++++++++++------------- workflow-visualiser.cabal | 9 +- 6 files changed, 515 insertions(+), 130 deletions(-) create mode 100644 app/Parser.hs diff --git a/app/Export.hs b/app/Export.hs index b8a51c3..6d63b46 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 Parser (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..2e05c81 100644 --- a/app/Index.hs +++ b/app/Index.hs @@ -6,47 +6,49 @@ module Index where - import Data.Yaml + -- 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 Parser - 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 +61,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..5fbcad7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,14 +1,16 @@ -module Main where +module Main (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 Parser (parse, ParseState (..), decodeWithComments1, decodeWithComments1Strict) import Export import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) import Data.Either (isLeft, fromLeft, fromRight) @@ -17,6 +19,15 @@ 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,12 +40,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 -- | Imports the YAML document specified in the first command line argument and @@ -44,8 +79,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 +116,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/Parser.hs b/app/Parser.hs new file mode 100644 index 0000000..7b24177 --- /dev/null +++ b/app/Parser.hs @@ -0,0 +1,224 @@ +{-# Language DuplicateRecordFields, + NoFieldSelectors, + OverloadedRecordDot #-} + +module Parser 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 + } + + + type Comment = Text + + + disp :: Int -> YAMLNode -> String + disp indent (Scalar b c a p) = replicate indent ' ' ++ "Sca: " ++ show b ++ " #" ++ show c ++ " " ++ show a ++ " @" ++ show (posLine p) ++ "\n" + disp indent (Mapping ct cm a p) = replicate indent ' ' ++ "Map:\n" ++ if null cm then disp' (indent + 2) ct else "" ++ " #" ++ show cm ++ " " ++ show a ++ " @" ++ show (posLine p) ++ "\n" where + disp' :: Int -> [(YAMLNode, YAMLNode)] -> String + disp' indent [] = "" + disp' indent ((k,v):xs) = replicate indent ' ' ++ toStr k ++ ":\n" ++ disp (indent + 4) v ++ disp' indent xs + toStr :: YAMLNode -> String + toStr (Scalar b c _ _) = "| " ++ show b ++ if not (null c) then (" #" ++ show c) else "" + disp indent (Sequence ch cm a p) = replicate indent ' ' ++ "Seq:\n" ++ disp'' (indent + 4) ch ++ " #" ++ show cm ++ " " ++ show a ++ " @" ++ show (posLine p) ++ "\n" where + disp'' :: Int -> [YAMLNode] -> String + disp'' indent [] = "" + disp'' indent (x:xs) = replicate indent ' ' ++ toStr' (indent + 4) x ++ disp'' indent xs + toStr' :: Int -> YAMLNode -> String + toStr' _ (Scalar b c _ _) = "- " ++ show b ++ if not (null c) then (" #" ++ show c) else "" + toStr' indent x = "- " ++ disp indent x + + instance Show YAMLNode where + show = disp 0 + + + + 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/app/Workflow.hs b/app/Workflow.hs index 36ebbb8..185e5d6 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -8,13 +8,15 @@ 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 Parser + 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/workflow-visualiser.cabal b/workflow-visualiser.cabal index 8ef928a..cc5939a 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, + Parser -- LANGUAGE extensions used by modules in this package. -- other-extensions: build-depends: base ^>=4.16.3.0, - yaml >= 0.11.11.0, + -- yaml >= 0.11.11.0, aeson >= 2.1.2.0, + HsYAML >= 0.2.1.1, bytestring, containers, text, vector, directory, - regex-tdfa + regex-tdfa, + mtl hs-source-dirs: app default-language: Haskell2010