uni2work.workflows.visualiser/dsl/app/DSL.hs

-- 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()
  --   }    
  -- }