diff --git a/.gitignore b/.gitignore index 7d4322b..a5cea65 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ # SPDX-License-Identifier: AGPL-3.0-or-later /dist-newstyle +/dsl/dist-newstyle .stack-work CHANGELOG.md test.json diff --git a/dsl/app/DSL.hs b/dsl/app/DSL.hs new file mode 100644 index 0000000..79ff29b --- /dev/null +++ b/dsl/app/DSL.hs @@ -0,0 +1,189 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- 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() + -- } + -- } diff --git a/dsl/app/Main.hs b/dsl/app/Main.hs new file mode 100644 index 0000000..4972561 --- /dev/null +++ b/dsl/app/Main.hs @@ -0,0 +1,30 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- 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 diff --git a/dsl/dsl.cabal b/dsl/dsl.cabal new file mode 100644 index 0000000..2a6da7f --- /dev/null +++ b/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 diff --git a/dsl/dsl.cabal.license b/dsl/dsl.cabal.license new file mode 100644 index 0000000..b1bfe50 --- /dev/null +++ b/dsl/dsl.cabal.license @@ -0,0 +1,2 @@ +SPDX-FileCopyrightText: 2023 David Mosbach +SPDX-License-Identifier: AGPL-3.0-or-later