parser preserves anchors & comments

app/Export.hs

@@ -6,9 +6,14 @@ module Export where
 
   import Data.Aeson
   import Data.Map hiding (fromList)
-  import Data.Vector hiding ((!))
+  import Data.Vector hiding ((!), (++))
-  import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..))
+  import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..), Message(..), Label(..), Viewers (..))
-  import Data.Text (pack)
+  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",

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,
+    graphFile       :: Text,
-    category        :: Maybe String,
+    category        :: Maybe Text,
-    defScope        :: Maybe String,
+    defScope        :: Maybe Text,
     defDescription  :: Maybe Description,
     instDescription :: Maybe Description,
-    instances       :: Value
+    instances       :: YAMLNode
-  } deriving (Show, Generic)
+  } deriving Show
 
-  instance FromJSON Entry where
+  instance FromYAML' Entry where
-    parseJSON (Object o) = Entry <$>
+    fromYAML (Mapping mapping _ _ _) = Entry
-                           o .:  "graph-file" <*>
+                                       <$> mapping <|  "graph-file"
-                           o .:? "category" <*>
+                                       <*> mapping <|? "category"
-                           o .:? "definition-scope" <*>
+                                       <*> mapping <|? "definition-scope"
-                           o .:? "definition-description" <*>
+                                       <*> mapping <|? "definition-description"
-                           o .:? "instance-description" <*>
+                                       <*> mapping <|? "instance-description"
-                           o .:  "instances"
+                                       <*> mapping <|  "instances"
-    parseJSON _ = error "Unexpected yaml"
+    -- parseJSON _ = error "Unexpected yaml"
 
-  type Title = String
+  type Title = Text
-  type Content = String
+  type Content = Text
 
   data Description = Description {
-    fallbackLang :: Maybe String,
+    fallbackLang :: Maybe Text,
     fallback     :: (Maybe Title, Maybe Content),
-    translations :: Map String (Maybe Title, Maybe Content)
+    translations :: Map Text (Maybe Title, Maybe Content)
-  } deriving (Show, Generic)
+  } deriving Show
 
-  instance FromJSON Description where
+  instance FromYAML' Description where
-    parseJSON (Object o) = Description <$>
+    fromYAML (Mapping mapping _ _ _) = Description
-                           o .:? "fallback-lang" <*>
+                                       <$> mapping <|? "fallback-lang"
-                           o .:  "fallback" <*>
+                                       <*> mapping <|  "fallback"
-                           o .:  "translations"
+                                       <*> 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 :: [Entry] -> Text -> Entry
-    query [] _ = error $ "No entries left for " ++ file
+    query [] _ = error $ "No entries left for " ++ show file
     query (x:xs) file = if x.graphFile == file then x else query xs file

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
+    let decoded = decodeWithComments1Strict content :: Either (Pos, String) Workflow
-    if isLeft decoded then throw (fromLeft undefined decoded) else do
+    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
 
 

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]

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,
+    nodes  :: Map Text State,
-    stages :: Maybe Value
+    stages :: Maybe YAMLNode,
-  } deriving (Show, Generic)
+    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),
+    edges    :: Maybe (Map Text Action),
-    messages :: Maybe [Value]
+    messages :: Maybe [Message],
-  } deriving (Show, Generic)
+    comment :: [Comment],
+    anchor :: AnchorData
+  } deriving Show
 
-  instance FromJSON State where
+  instance FromYAML' State where
-    parseJSON (Object o) = State <$>
+    fromYAML (Mapping mapping comment anchor _) = State
-                           o .:? "viewers" <*>
+                                                  <$> mapping <|? "viewers"
-                           o .:? "payload-view" <*>
+                                                  <*> mapping <|? "payload-view"
-                           o .:? "final" <*>
+                                                  <*> mapping <|? "final"
-                           o .:? "edges" <*>
+                                                  <*> mapping <|? "edges"
-                           o .:? "messages"
+                                                  <*> mapping <|? "messages"
-    parseJSON _ = error "unexpected state data format"
+                                                  <*> 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
+  instance FromYAML' Final where
-    parseJSON v = case v of
+    fromYAML (Scalar bytes comment anchor _) = Final
-                    String _ -> Final <$> parseJSON v
+                                               <$> pure (show $ decodeUtf8 bytes)
-                    Bool x   -> Final <$> parseJSON (String . pack . show $ x)
+                                               <*> 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,
+    name    :: Either Label Text,
-    viewers :: Maybe [Map String Value]
+    viewers :: Maybe Viewers,
-  } deriving (Show, Generic)
+    comment :: [Comment],
+    anchor :: AnchorData
+  } deriving Show
 
-  instance FromJSON StateViewers where
+  instance FromYAML' StateViewers where
-    parseJSON (Object o) = StateViewers <$>
+    fromYAML (Mapping mapping comment anchor _) = StateViewers
-                           ((Left <$> o .:  "display-label") <|> (Right <$> o .:  "display-label")) <*>
+                                                  <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label"))
-                           o .:? "viewers"
+                                                  <*> mapping <|? "viewers"
-    parseJSON _ = error "unexpected stateViewers data format"
+                                                  <*> 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,
+    fallback :: Maybe Text,
-    translations :: Maybe Value
+    fallbackLang :: Maybe Text,
-  } deriving (Show, Generic)
+    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,
+    mode      :: Maybe Text,
-    source    :: Maybe String,
+    source    :: Maybe Text,
     name      :: Maybe Label,
-    actors    :: Maybe [Map String Value],
+    actors    :: Maybe Viewers,
-    viewActor :: Maybe [Map String Value],
+    viewActor :: Maybe Viewers,
-    viewers   :: Maybe [Map String Value],
+    viewers   :: Maybe Viewers,
-    messages  :: Maybe [Value],
+    messages  :: Maybe [Message],
-    form      :: Maybe Value
+    form      :: Maybe YAMLNode,
-  } deriving (Show, Generic)
+    comment :: [Comment],
+    anchor :: AnchorData
+  } deriving Show
 
-  instance FromJSON Action where
+  instance FromYAML' Action where
-    parseJSON (Object o) = Action <$>
+    fromYAML (Mapping mapping comment anchor _) = Action
-                           o .:? "mode" <*>
+                                                  <$> mapping <|? "mode"
-                           o .:? "source" <*>
+                                                  <*> mapping <|? "source"
-                           o .:? "display-label" <*>
+                                                  <*> mapping <|? "display-label"
-                           o .:? "actors" <*>
+                                                  <*> mapping <|? "actors"
-                           o .:? "view-actor" <*>
+                                                  <*> mapping <|? "view-actor"
-                           o .:? "viewers" <*>
+                                                  <*> mapping <|? "viewers"
-                           o .:? "messages" <*>
+                                                  <*> mapping <|? "messages"
-                           o .:? "form"
+                                                  <*> mapping <|? "form"
-    parseJSON _ = error "unexpected action data format"
+                                                  <*> 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",
+    nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor,
-                                  viewers = Just $ StateViewers (Left (Label (Just initID) Nothing)) Nothing,
+                                  viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor)) Nothing [] NoAnchor,
                                   payload = Nothing,
                                   edges = Nothing,
-                                  messages = Nothing}) wf.nodes
+                                  messages = Nothing,
-    analyse :: String -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData)
+                                  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),
+                          ("viewers",  Vie viewers),
-                          ("final",    Single final),
+                          ("final",    Single $ pack final),
-                          ("messages", List $ Prelude.map Val messages),
+                          ("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)
+                                      Left y  -> (fromMaybe "" y.fallback, fromMaybe (Viewers [] [] NoAnchor) x.viewers)
-                                      Right y -> (y, fromMaybe [empty :: Map String Value] 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
+      payload = maybe (Val (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0))) Dict s.payload
-    updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData
+    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
+    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 :: String -> Action -> String -> Map String Entry
+    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),
+                                         ("actors",     Vie actors),
-                                         ("viewers",    List $ Prelude.map Dict viewers),
+                                         ("viewers",    Vie viewers),
-                                         ("view-actor", List $ Prelude.map Dict viewActor),
+                                         ("view-actor", Vie viewActor),
-                                         ("messages",   List $ Prelude.map Val messages),
+                                         ("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
+      actors = fromMaybe (Viewers [] [] NoAnchor) a.actors
-      viewers = fromMaybe [] a.viewers
+      viewers = fromMaybe (Viewers [] [] NoAnchor) a.viewers
-      viewActor = fromMaybe [] a.viewActor
+      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
 
   ---------------------------------------

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