uni2work.workflows.visualiser/dsl/DSL.hs

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