diff --git a/app/Main.hs b/app/Main.hs index 542bfb9..0fec81a 100644 --- a/app/Main.hs +++ b/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) --------------------------------------- @@ -45,6 +46,7 @@ module Main where main :: IO () main = getArgs >>= process >>= finish where process :: [String] -> IO Bool + process ["--dsl"] = dslMain >> return True process [path] = printEvents path >> runParser path >> return True process args@[_, _] = generateJSON args >> return False process args@["--all", src, to] = processDirectory src to >> return False diff --git a/dsl/app/DSL.hs b/dsl/app/DSL.hs index 2b68198..3ff1011 100644 --- a/dsl/app/DSL.hs +++ b/dsl/app/DSL.hs @@ -2,7 +2,10 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE FlexibleInstances, NoFieldSelectors, OverloadedRecordDot, DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances, + NoFieldSelectors, + OverloadedRecordDot, + DuplicateRecordFields #-} module DSL ( parseSubStageDef, @@ -13,7 +16,8 @@ module DSL ( Literal (..), Variable (..), Conjunction (..), - Predicate (..) + Predicate (..), + LogVar ) where import qualified Data.ByteString.Lazy as BSL @@ -59,14 +63,14 @@ module DSL ( | 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 + 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 @@ -118,9 +122,10 @@ module DSL ( | otherwise = undefined parseShowWhen :: Parsec BSL.ByteString u When - parseShowWhen = string "when" + parseShowWhen = toWhen <$> optionMaybe ( + string "when" *> skipMany1 space - *> (toWhen <$> optionMaybe (try (string isFulfilled) <|> string isUnfulfilled)) + *> (try (string isFulfilled) <|> string isUnfulfilled)) where toWhen :: Maybe String -> When toWhen Nothing = Always diff --git a/dsl/app/DSLMain.hs b/dsl/app/DSLMain.hs index a196919..0c008e1 100644 --- a/dsl/app/DSLMain.hs +++ b/dsl/app/DSLMain.hs @@ -2,11 +2,14 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -module DSLMain where +module DSLMain (dslMain) where import DSL (parseSubStageDef) import Data.ByteString.Lazy.UTF8 as BSLU - + import Transpiler (resolve) + import Control.Monad (unless) + import Data.Either (isLeft, fromRight) + program = "required substage InterneBearbeitung when unfulfilled {\n" ++ @@ -26,5 +29,32 @@ module DSLMain where "}\n" ++ "}\n" - main :: IO () - main = print . parseSubStageDef $ BSLU.fromString program + + program2 = + "optional substage Vorbereitung {\n" ++ + + "let always_required = not edge_in_history(some-edge)\n" ++ + "let sometimes_required = { payload_filled(foo), not bar }\n" ++ + + "case {\n" ++ + "always_required,\n" ++ + "edge_in_history(abbrechen),\n" ++ + "not payload_filled(some-payload)\n" ++ + "}\n" ++ + + "case {\n" ++ + "always_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 + diff --git a/dsl/app/Transpiler.hs b/dsl/app/Transpiler.hs index 3110e16..8fada4c 100644 --- a/dsl/app/Transpiler.hs +++ b/dsl/app/Transpiler.hs @@ -2,14 +2,17 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, NoFieldSelectors, DuplicateRecordFields, TupleSections #-} +{-# LANGUAGE OverloadedRecordDot, + OverloadedStrings, + NoFieldSelectors, + DuplicateRecordFields, + TupleSections #-} module Transpiler where import DSL import Data.YAML (ToYAML (..), mapping, (.=)) import Data.Text (Text, pack) - import YamlParser (AnchorData (..)) - import Data.YAML.Event (ScalarStyle(Literal)) + import YamlParser (AnchorData (..), YAMLNode (Sequence)) import Control.Monad.State (State, evalState, get, put, unless, when) import Data.Map (Map, empty) import qualified Data.Map as M @@ -24,32 +27,57 @@ module Transpiler where data DNFLiteral = DNFLit { anchor :: AnchorData, literal :: ResolvedLiteral - } + } deriving (Show) type DNF = [[DNFLiteral]] + + data ResolvedSubStage = RSubStage { + head :: Head, + body :: DNF + } deriving (Show) - instance ToYAML SubStage where - toYAML(SubStage head body) = mapping [ + 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, - "predicate" .= mapping [ "dnf-terms" .= ("" :: Text)] -- toYAML (resolve body) ] + "display-label" .= (undefined :: Text), + "predicate" .= mapping [ "dnf-terms" .= toYAML body ] ] + instance ToYAML DNFLiteral where + toYAML (DNFLit anchor (Pred' p)) = mapping [ + "tag" .= ("variable" :: Text), + "var" .= mapping [ + "tag" .= predToText p, + predToText p .= pack p.ref + ] + ] + where + 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) --(Either ResolveError) + type Resolver = ExceptT ResolveError (State StateData) - resolve :: Body -> Either ResolveError DNF - resolve body = evalState (runExceptT (eval body)) initState + resolve :: SubStage -> Either ResolveError ResolvedSubStage + resolve (SubStage head body) = evalState (runExceptT (RSubStage head <$> eval body)) initState where initState = StateData empty (M.map (, False) body.variables) [] @@ -91,7 +119,7 @@ module Transpiler where countNot x (Neg n) = countNot (x+1) n countNot x lit = (lit, x) evalPredicate :: Literal -> Resolver DNFLiteral - evalPredicate (Pred (EdgesInHistory _)) = undefined + 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 @@ -100,23 +128,25 @@ module Transpiler where evalVariable :: Bool -> Literal -> Resolver (Either DNFLiteral [DNFLiteral]) evalVariable negated (Var v) = do state <- get - let maybeVar = M.lookup v state.innerVariables - if isNothing maybeVar then throwError . ResolveError $ "Reference of unassigned variable: " ++ v else do - let (var, alreadyUsed) = fromJust maybeVar - unless alreadyUsed . put $ state { innerVariables = M.adjust (\(x,_) -> (x,True)) v state.innerVariables } - let anchor = if alreadyUsed then AnchorAlias (pack v) else AnchorDef (pack v) - 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 [] + 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 () - - - instance ToYAML DNFLiteral where - toYAML (DNFLit anchor literal) = mapping [ - -- "dnf-terms" .= toYAML - ] \ No newline at end of file