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

added negated case for yaml encoding

Browse Source
This commit is contained in:
David Mosbach 2023-09-02 02:28:50 +02:00
parent 79fd7c8ab6
commit 8972304232
2 changed files with 10 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
dsl/app/DSLMain.hs
View File

@ -9,6 +9,7 @@ module DSLMain (dslMain) where
import Transpiler (resolve) import Transpiler (resolve)
import Control.Monad (unless) import Control.Monad (unless)
import Data.Either (isLeft, fromRight) import Data.Either (isLeft, fromRight)
import Data.YAML (encode)
program = program =
"required substage InterneBearbeitung when unfulfilled {\n" ++ "required substage InterneBearbeitung when unfulfilled {\n" ++
@ -57,4 +58,7 @@ module DSLMain (dslMain) where
putStrLn "\n\t### Transpiler ###\n" putStrLn "\n\t### Transpiler ###\n"
let transp = resolve $ fromRight undefined subStage let transp = resolve $ fromRight undefined subStage
print transp print transp
putStrLn "\n\t ### YAML ###\n"
putStrLn . BSLU.toString $ encode [fromRight undefined transp]

8
dsl/app/Transpiler.hs
View File

@ -48,20 +48,24 @@ module Transpiler where
] ]
instance ToYAML DNFLiteral where instance ToYAML DNFLiteral where
toYAML (DNFLit anchor (Pred' p)) = mapping [ toYAML (DNFLit anchor pred) = mapping [
"tag" .= ("variable" :: Text), "tag" .= tag,
"var" .= mapping [ "var" .= mapping [
"tag" .= predToText p, "tag" .= predToText p,
predToText p .= pack p.ref predToText p .= pack p.ref
] ]
] ]
where where
(tag, p) = case pred of
Pred' x -> ("variable" :: Text, x)
Neg' x -> ("negated", x)
predToText :: Predicate -> Text predToText :: Predicate -> Text
predToText (EdgeInHistory _) = "edge-in-history" predToText (EdgeInHistory _) = "edge-in-history"
predToText (NodeInHistory _) = "node-in-history" predToText (NodeInHistory _) = "node-in-history"
predToText (PayloadFilled _) = "payload-filled" predToText (PayloadFilled _) = "payload-filled"
predToText (PreviousNode _) = "previous-node" predToText (PreviousNode _) = "previous-node"
predToText x = error $ show x ++ " is not fully resolved" predToText x = error $ show x ++ " is not fully resolved"
newtype ResolveError = ResolveError String newtype ResolveError = ResolveError String