Merge branch 'main' into stages-dsl

app/Main.hs

@@ -33,6 +33,7 @@ module Main where
   import Data.Text.Encoding (encodeUtf8, decodeUtf8)
   import Data.Text.Lazy (toStrict)
   import Debug.Trace (trace)
+  import DSLMain (dslMain)
   import ServerMain (serverMain)
   
   ---------------------------------------
@@ -46,6 +47,7 @@ module Main where
   main :: IO ()
   main = getArgs >>= process >>= finish where
     process :: [String] -> IO Bool
+    process ["--dsl"] = dslMain >> return True
     process ["--server"] = serverMain >> return True
     process [path] = printEvents path >> runParser path >> return True
     process args@[_, _] = generateJSON args >> return False

dsl/DSL.hs

@@ -0,0 +1,212 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# LANGUAGE FlexibleInstances,
+             NoFieldSelectors,
+             OverloadedRecordDot,
+             DuplicateRecordFields #-}
+
+module DSL (
+  parseSubStageDef,
+  SubStage (..),
+  Head (..),
+  Body (..),
+  When (..),
+  Literal (..),
+  Variable (..),
+  Conjunction (..),
+  Predicate (..),
+  LogVar
+  ) where
+
+  import qualified Data.ByteString.Lazy as BSL
+
+  import Text.Parsec 
+  import Debug.Trace (traceShow)
+  import Data.Functor ( ($>) )
+  import Data.YAML.Event (ScalarStyle(Literal))
+  import Data.Map (Map, empty, insert)
+  
+
+  type Stage = [SubStage]
+
+  data SubStage = SubStage {
+    head :: Head,
+    body :: Body
+  } deriving Show
+
+  data Head = Head {
+    required :: Bool,
+    id :: String,
+    showWhen :: When
+  } deriving Show
+
+  data When = Always | Fulfilled | Unfulfilled  deriving Show
+
+  data Body = Body {
+    variables :: Map String Variable,
+    dnf :: [Conjunction]
+  } deriving Show
+
+  data Variable = Single {
+      id :: String,
+      lit :: Literal
+    } | Block {
+      id :: String,
+      conj :: Conjunction
+    } deriving Show
+
+  type Conjunction = [Literal]
+
+  data Literal = Pred Predicate
+               | Var String -- TODO refine to Single
+               | Neg Literal  deriving Show
+
+  data Predicate = EdgeInHistory { ref :: LogVar }
+                 | NodeInHistory { ref :: LogVar }
+                 | PayloadFilled { ref :: LogVar }
+                 | PreviousNode  { ref :: LogVar }
+                 | EdgesInHistory { refs :: [LogVar] }
+                 | NodesInHistory { refs :: [LogVar] }
+                 | PayloadsFilled { refs :: [LogVar] }
+                 | PreviousNodes  { refs :: [LogVar] }  deriving Show
+
+  type LogVar = String
+
+  ----------------------------------------------------
+
+
+  isOptional = "optional"
+  isRequired = "required"
+
+  isFulfilled = "fulfilled"
+  isUnfulfilled = "unfulfilled"
+
+  spaceChars :: [Char]
+  spaceChars = [' ', '\n', '\r', '\t', '\v']
+
+  parseSingle :: Monad m => ParsecT BSL.ByteString u m String
+  parseSingle = many (noneOf spaceChars)
+
+  baseBrackets :: Monad m => Char -> Char -> ParsecT BSL.ByteString u m a -> ParsecT BSL.ByteString u m a
+  baseBrackets open close = between (spaces *> char open <* spaces)
+                                  (spaces *> char close <* spaces)
+
+  curlyBrackets :: Monad m => ParsecT BSL.ByteString u m a -> ParsecT BSL.ByteString u m a
+  curlyBrackets = baseBrackets '{' '}'
+
+  roundBrackets :: Monad m => ParsecT BSL.ByteString u m a -> ParsecT BSL.ByteString u m a
+  roundBrackets = baseBrackets '(' ')'
+
+  squareBrackets :: Monad m => ParsecT BSL.ByteString u m a -> ParsecT BSL.ByteString u m a
+  squareBrackets = baseBrackets '[' ']'
+
+
+
+  parseSubStage :: Parsec BSL.ByteString u SubStage
+  parseSubStage = SubStage <$> parseHead <*> curlyBrackets parseBody
+
+  parseHead :: Parsec BSL.ByteString u Head
+  parseHead = Head <$> (parseRequired <* spaces <* string "substage")
+                   <*> (skipMany1 space *> parseLogVar)
+                   <*> (skipMany1 space *> parseShowWhen)
+
+  parseRequired :: Parsec BSL.ByteString u Bool
+  parseRequired = spaces *> (reqToBool <$> (try (string isOptional) <|> string isRequired))
+    where
+      reqToBool :: String -> Bool
+      reqToBool s
+        | s == isOptional = False
+        | s == isRequired = True
+        | otherwise = undefined
+
+  parseShowWhen :: Parsec BSL.ByteString u When
+  parseShowWhen = toWhen <$> optionMaybe (
+                     string "when"
+                  *> skipMany1 space
+                  *> (try (string isFulfilled) <|> string isUnfulfilled))
+    where
+      toWhen :: Maybe String -> When
+      toWhen Nothing = Always
+      toWhen (Just s)
+        | s == isFulfilled = Fulfilled
+        | s == isUnfulfilled = Unfulfilled
+        | otherwise = undefined
+
+
+  parseBody :: Parsec BSL.ByteString u Body
+  parseBody = toBody (empty, []) <$> bodyContentParser
+    where
+      toBody :: (Map String Variable, [Conjunction]) -> [Either Variable Conjunction] -> Body
+      toBody acc [] = uncurry Body acc
+      toBody (vars, conjs) ((Left v):xs) = toBody (insert v.id v vars, conjs) xs
+      toBody (vars, conjs) ((Right c):xs) = toBody (vars, c : conjs) xs
+      bodyContentParser :: Parsec BSL.ByteString u [Either Variable Conjunction]
+      bodyContentParser = many (spaces *> (try (Left <$> parseVariable) <|> (Right <$> parseCase)))
+
+  parseVariable :: Parsec BSL.ByteString u Variable
+  parseVariable = string "let" *> skipMany1 space *> (
+          try (Block <$> parseInitialisation <*> curlyBrackets parseConjunction)
+      <|> (Single <$> parseInitialisation <*> parseLiteral)
+    ) where
+      parseInitialisation = parseLogVar <* (skipMany1 space *> char '=' *> skipMany1 space)
+
+
+  parseConjunction :: Parsec BSL.ByteString u Conjunction
+  parseConjunction = (:) <$> parseLiteral <*> many (try (spaces *> char ',' *> spaces *> parseLiteral))
+
+  parseCase :: Parsec BSL.ByteString u Conjunction
+  parseCase = string "case" *> curlyBrackets parseConjunction
+
+  parseLiteral :: Parsec BSL.ByteString u Literal
+  parseLiteral =    try (Pred <$> parsePredicate)
+                <|> try (Neg <$> parseNegation)
+                <|> (Var <$> parseLogVar) -- TODO prevent use of reserved keywords
+    where
+      parseNegation = string "not" *> skipMany1 space *> parseLiteral
+
+
+  parsePredicate :: Parsec BSL.ByteString u Predicate
+  parsePredicate =    try (EdgeInHistory  <$> (string "edge_in_history"  *> roundBrackets parseLogVar))
+                  <|> try (NodeInHistory  <$> (string "node_in_history"  *> roundBrackets parseLogVar))
+                  <|> try (PayloadFilled  <$> (string "payload_filled"   *> roundBrackets parseLogVar))
+                  <|> try (PreviousNode   <$> (string "previous_node"    *> roundBrackets parseLogVar))
+                  <|> try (EdgesInHistory <$> (string "edges_in_history" *> roundBrackets (try (squareBrackets parseLogVars) <|> parseLogVars)))
+                  <|> try (NodesInHistory <$> (string "nodes_in_history" *> roundBrackets (try (squareBrackets parseLogVars) <|> parseLogVars)))
+                  <|> try (PayloadsFilled <$> (string "payloads_filled"  *> roundBrackets (try (squareBrackets parseLogVars) <|> parseLogVars)))
+                  <|>     (PreviousNodes  <$> (string "previous_nodes"   *> roundBrackets (try (squareBrackets parseLogVars) <|> parseLogVars)))
+
+
+  parseLogVar :: Parsec BSL.ByteString u LogVar
+  parseLogVar = (:) <$> alphaNum <*> many (try alphaNum <|> oneOf ['-', '_'])
+
+  parseLogVars :: Parsec BSL.ByteString u [LogVar]
+  parseLogVars = try ((:) <$> parseLogVar <*> many (spaces *> char ',' *> spaces *> parseLogVar)) <|> (spaces $> [])
+
+
+
+  parseSubStageDef :: BSL.ByteString -> Either ParseError SubStage
+  parseSubStageDef = parse (parseSubStage <* eof) ""
+
+
+
+
+
+  -- required substage InterneBearbeitung when unfulfilled {
+
+  --   let always_required = not edges_in_history([a, b, c])
+  --   let sometimes_required = { payload_filled(foo), not bar }
+
+  --   case {
+  --     always_required,
+  --     edge_in_history(abbrechen),
+  --     not payloads_filled([]),
+  --     nodes_in_history([x, y, z])
+  --   }
+
+  --   case {
+  --     always_required,
+  --     not previous_nodes()
+  --   }    
+  -- }

dsl/DSLMain.hs

@@ -0,0 +1,71 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# LANGUAGE OverloadedRecordDot,
+             NoFieldSelectors #-}
+
+module DSLMain (dslMain) where
+  import DSL (parseSubStageDef)
+
+  import Data.ByteString.Lazy.UTF8 as BSLU
+  import Transpiler (resolve, ResolvedData (..), Warning (Warning))
+  import Control.Monad (unless)
+  import Data.Either (isLeft, fromRight)
+  import Data.YAML (encode)
+  
+  program =
+      "required substage InterneBearbeitung when unfulfilled {\n" ++
+
+        "let always_required = not edges_in_history([a, b, c])\n" ++
+        "let sometimes_required = { payload_filled(foo), not bar }\n" ++
+
+        "case {\n" ++
+          "always_required,\n" ++
+          "edge_in_history(abbrechen),\n" ++
+          "not payloads_filled([]),\n" ++
+          "nodes_in_history([x, y, z])\n" ++
+        "}\n" ++
+
+        "case {\n" ++
+          "always_required,\n" ++
+          "not previous_nodes()\n" ++
+        "}\n" ++    
+      "}\n"
+
+
+  program2 =
+    "optional substage Vorbereitung {\n" ++
+
+        "let always_required = not edge_in_history(some-edge)\n" ++
+        "let sometimes_required = { payload_filled(fill-me), not bar }\n" ++
+        "let bar = payload_filled(do-not-fill-me)\n" ++
+
+        "case {\n" ++
+          "always_required,\n" ++
+          "edge_in_history(abbrechen),\n" ++
+          "not payload_filled(some-payload)\n" ++
+        "}\n" ++
+
+        "case {\n" ++
+          "always_required,\n" ++
+          -- "sometimes_required,\n" ++
+          "not previous_node(last-node)\n" ++
+        "}\n" ++    
+      "}\n"
+
+  dslMain :: IO ()
+  dslMain = do
+    putStrLn "\n\t   ### AST ###\n"
+    let subStage = parseSubStageDef $ BSLU.fromString program2
+    print subStage
+    unless (isLeft subStage) $ do
+      putStrLn "\n\t### Transpiler ###\n"
+      let transp = resolve $ fromRight undefined subStage
+      print transp
+      putStrLn "\n\t   ### YAML ###\n"
+      let rData = fromRight undefined transp
+      mapM_ print rData.warnings
+      putStrLn . BSLU.toString $ encode [rData.subStage]
+
+

dsl/Transpiler.hs

@@ -0,0 +1,179 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# LANGUAGE OverloadedRecordDot,
+             OverloadedStrings,
+             NoFieldSelectors,
+             DuplicateRecordFields,
+             TupleSections #-}
+
+module Transpiler where
+  import DSL
+  import Data.YAML (ToYAML (..), mapping, (.=))
+  import Data.Text (Text, pack)
+  import YamlParser (AnchorData (..), YAMLNode (Sequence))
+  import Control.Monad.State (State, evalState, runState, get, put, unless, when)
+  import Data.Map (Map, empty)
+  import qualified Data.Map as M
+  import Control.Monad.Except (ExceptT, runExceptT, throwError)
+  import Data.Either (fromLeft)
+  import Data.Maybe (fromJust, isNothing)
+  
+
+  data ResolvedLiteral = Pred' { pred :: Predicate }
+                       | Neg' { pred :: Predicate }  deriving Show
+  
+  data DNFLiteral = DNFLit {
+    anchor  :: AnchorData,
+    literal :: ResolvedLiteral
+  } deriving (Show)
+
+  type DNF = [[DNFLiteral]]
+
+  data ResolvedSubStage = RSubStage {
+    head :: Head,
+    body :: DNF
+  } deriving (Show)
+  
+  instance ToYAML ResolvedSubStage where
+    toYAML(RSubStage head body) = mapping [
+        "mode"      .= if head.required then "required" else "optional" :: Text,
+        "show-when" .= case head.showWhen of
+                          Always      -> "always"
+                          Fulfilled   -> "fulfilled"
+                          Unfulfilled -> "unfulfilled" :: Text,
+        "display-label" .= (undefined :: Text),
+        "predicate" .= mapping [ "dnf-terms" .= toYAML body ]
+      ]
+
+  instance ToYAML DNFLiteral where
+    toYAML (DNFLit anchor pred) = mapping [
+        "tag" .= tag,
+        "var" .= mapping [
+          "tag" .= predToText p,
+          predToText p .= pack p.ref
+        ]
+      ]
+        where
+          (tag, p) = case pred of
+            Pred' x -> ("variable" :: Text, x)
+            Neg' x -> ("negated", x)
+          predToText :: Predicate -> Text
+          predToText (EdgeInHistory _) = "edge-in-history"
+          predToText (NodeInHistory _) = "node-in-history"
+          predToText (PayloadFilled _) = "payload-filled"
+          predToText (PreviousNode  _) = "previous-node"
+          predToText x = error $ show x ++ " is not fully resolved"
+    
+
+  newtype ResolveError = ResolveError String
+
+  instance Show ResolveError where
+    show (ResolveError s) = s
+
+  data StateData = StateData {
+    innerVariables :: Map String (Variable, Bool), -- True means "already used" => anchor ref. False means "not used before" => new anchor
+    outerVariables :: Map String (Variable, Bool),
+    disjunction    :: DNF
+  }
+
+  type Resolver = ExceptT ResolveError (State StateData)
+  newtype Warning = Warning String deriving Show
+  data ResolvedData = RData {
+    subStage :: ResolvedSubStage,
+    warnings :: [Warning]
+  } deriving (Show)
+
+  resolve :: SubStage -> Either ResolveError ResolvedData
+  resolve (SubStage head body) = evaluation
+    where
+      (evaluation, state) = runState (runExceptT (RData <$> (RSubStage head <$> eval body) <*> warnings)) initState
+      warnings = checkUnusedVariables
+      initState = StateData empty (M.map (, False) body.variables) []
+
+  checkUnusedVariables :: Resolver [Warning]
+  checkUnusedVariables = do
+    state <- get
+    let unusedInner = M.foldl f [] state.innerVariables
+    let unusedOuter = M.foldl f [] state.outerVariables
+    return $ unusedInner ++ unusedOuter
+      where
+        f :: [Warning] -> (Variable, Bool) -> [Warning]
+        f acc (_, True) = acc
+        f acc (var, False) = Warning ("Unused variable: " ++ id) : acc
+          where id = case var of
+                        Single id' _ -> id'
+                        Block id' _ -> id'
+
+
+  
+  eval :: Body -> Resolver DNF
+  eval (Body variables []) = get >>= \s -> return s.disjunction
+  eval (Body variables (c:dnf)) = do
+    conjunction <- evalConjunction c []
+    state <- get
+    put $ state {innerVariables = empty, disjunction = conjunction : state.disjunction}
+    eval $ Body variables dnf
+      where
+        evalConjunction :: Conjunction -> [DNFLiteral] -> Resolver [DNFLiteral]
+        evalConjunction [] acc = return acc
+        evalConjunction (l:ls) acc = do
+          lit <- evalLiteral l
+          case lit of
+            Left literal -> evalConjunction ls (literal : acc)
+            Right block -> evalConjunction ls (block ++ acc) -- Merge content of block conjunction variables
+        evalLiteral :: Literal -> Resolver (Either DNFLiteral [DNFLiteral])
+        evalLiteral n@(Neg _) = Left <$> evalNegation n
+        evalLiteral p@(Pred _) = Left <$> evalPredicate p
+        evalLiteral v@(Var _) = evalVariable False v
+        evalNegation :: Literal -> Resolver DNFLiteral -- Resolves redundant negations, e.g. `not not x` and also `let x = not y; let z = not x`
+        evalNegation (Neg n) = do
+          let (lit, count) = countNot 1 n
+          lit' <- case lit of {
+            Pred _ -> evalPredicate lit;
+            Var _ -> evalVariable True lit >>= \l -> return $ fromLeft (error "Preventing negated blocks failed") l;
+            Neg _ -> throwError . ResolveError $ "Could not resolve negation of: " ++ show n;
+          }
+          if even count then return lit' else do
+            let sign = case lit'.literal of {
+              Neg' _ -> Pred';
+              Pred' _ -> Neg';
+            }
+            return lit' { literal = sign lit'.literal.pred }
+        evalNegation x = throwError . ResolveError $ "Wrongfully labelt as negation:  " ++ show x
+        countNot :: Word -> Literal -> (Literal, Word)
+        countNot x (Neg n) = countNot (x+1) n
+        countNot x lit = (lit, x)
+        evalPredicate :: Literal -> Resolver DNFLiteral
+        evalPredicate (Pred (EdgesInHistory _)) = undefined -- Problem: how to handle negations without de morgan? forbid like negating block vars?
+        evalPredicate (Pred (NodesInHistory _)) = undefined
+        evalPredicate (Pred (PayloadsFilled _)) = undefined
+        evalPredicate (Pred (PreviousNodes _)) = undefined
+        evalPredicate (Pred p) = return $ DNFLit { anchor = NoAnchor, literal = Pred' p }
+        evalPredicate x = throwError . ResolveError $ "Wrongfully labelt as predicate: " ++ show x
+        evalVariable :: Bool -> Literal -> Resolver (Either DNFLiteral [DNFLiteral])
+        evalVariable negated (Var v) = do
+          state <- get
+          case M.lookup v state.innerVariables of
+            Just (var, alreadyUsed) -> processVarRef var alreadyUsed True negated
+            Nothing -> case M.lookup v state.outerVariables of
+              Just (var, alreadyUsed) -> processVarRef var alreadyUsed False negated
+              Nothing -> throwError . ResolveError $ "Reference of unassigned variable: " ++ v
+        processVarRef :: Variable -> Bool -> Bool -> Bool -> Resolver (Either DNFLiteral [DNFLiteral])
+        processVarRef var alreadyUsed isInner negated = do
+          let updateVars = M.adjust (\(x,_) -> (x,True)) var.id
+          state <- get
+          unless alreadyUsed . put $ if isInner
+                                     then state { innerVariables = updateVars state.innerVariables }
+                                     else state { outerVariables = updateVars state.outerVariables }
+          let anchor = if alreadyUsed then AnchorAlias (pack var.id) else AnchorDef (pack var.id)
+          case var of
+            Single _ (Pred p) -> return $ Left DNFLit { anchor = anchor, literal = Pred' p }
+            Single _ v'@(Var _) -> evalVariable negated v'
+            Single _ n@(Neg _) -> Left <$> (evalNegation n >>= \x -> return $ if x.anchor == NoAnchor then x {anchor = anchor} else x)
+            Block id conj -> preventBlockNegation negated id >> Right <$> evalConjunction conj []
+        preventBlockNegation :: Bool -> String -> Resolver ()
+        preventBlockNegation True s = throwError . ResolveError $ "Negating conjunction blocks is not permitted: " ++ s
+        preventBlockNegation False _ = return ()
+

workflow-visualiser.cabal

@@ -29,6 +29,9 @@ executable workflow-visualiser
                    Export,
                    Index,
                    YamlParser,
+                   DSLMain,
+                   DSL,
+                   Transpiler
                    ServerMain,
                    Routes,
                    Templates
@@ -47,11 +50,12 @@ executable workflow-visualiser
                       directory,
                       regex-tdfa,
                       mtl,
+                      parsec,
                       servant,
                       servant-server,
                       wai,
                       warp,
                       http-media,
                       ede
-    hs-source-dirs:   app, server
+    hs-source-dirs:   app, server, dsl
     default-language: Haskell2010