added dsl parser

.gitignore

@@ -3,6 +3,7 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 /dist-newstyle
+/dsl/dist-newstyle
 .stack-work
 CHANGELOG.md
 test.json

dsl/app/DSL.hs

@@ -0,0 +1,189 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# LANGUAGE FlexibleInstances #-}
+
+module DSL (parseSubStageDef, SubStage) where
+
+  import qualified Data.ByteString.Lazy as BSL
+
+  import Text.Parsec 
+  import Debug.Trace (traceShow)
+  import Data.Functor ( ($>) )
+  
+
+  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 :: [Variable],
+    dnf :: [Conjunction]
+  } deriving Show
+
+  data Variable = Single String Literal | Block String Conjunction  deriving Show
+
+  type Conjunction = [Literal]
+
+  data Literal = Pred Predicate
+               | Var String -- TODO refine to Single
+               | Neg Literal  deriving Show
+
+  data Predicate = EdgeInHistory LogVar
+                 | NodeInHistory LogVar
+                 | PayloadFilled LogVar
+                 | PreviousNode  LogVar
+                 | EdgesInHistory [LogVar]
+                 | NodesInHistory [LogVar]
+                 | PayloadsFilled [LogVar]
+                 | PreviousNodes  [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 =    string "when"
+                  *> skipMany1 space
+                  *> (toWhen <$> optionMaybe (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 ([], []) <$> bodyContentParser
+    where
+      toBody :: ([Variable], [Conjunction]) -> [Either Variable Conjunction] -> Body
+      toBody acc [] = uncurry Body acc
+      toBody (vars, conjs) ((Left v):xs) = toBody (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 String
+  parseLogVar = (:) <$> alphaNum <*> many (try alphaNum <|> oneOf ['-', '_'])
+
+  parseLogVars :: Parsec BSL.ByteString u [String]
+  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/app/Main.hs

@@ -0,0 +1,30 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Main where
+  import DSL (parseSubStageDef)
+
+  import Data.ByteString.Lazy.UTF8 as BSLU
+
+  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"
+
+  main :: IO ()
+  main = print . parseSubStageDef $ BSLU.fromString program

dsl/dsl.cabal

@@ -0,0 +1,38 @@
+cabal-version:      2.4
+name:               dsl
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+author:             David Mosbach
+maintainer:         david.mosbach@live.de
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+executable dsl
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    other-modules: DSL
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base ^>=4.16.4.0,
+                      bytestring,
+                      mtl,
+                      parsec,
+                      utf8-string
+    hs-source-dirs:   app
+    default-language: Haskell2010

dsl/dsl.cabal.license

@@ -0,0 +1,2 @@
+SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+SPDX-License-Identifier: AGPL-3.0-or-later