From 46b038bd47430b1458d0e2ff297f9385f13e34e3 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 1 Sep 2023 22:29:30 +0200 Subject: [PATCH] WIP: adding transpiler --- dsl/app/DSL.hs | 36 +++++++--- dsl/app/{Main.hs => DSLMain.hs} | 2 +- dsl/app/Transpiler.hs | 122 ++++++++++++++++++++++++++++++++ dsl/dsl.cabal | 38 ---------- workflow-visualiser.cabal | 11 ++- 5 files changed, 158 insertions(+), 51 deletions(-) rename dsl/app/{Main.hs => DSLMain.hs} (97%) create mode 100644 dsl/app/Transpiler.hs delete mode 100644 dsl/dsl.cabal diff --git a/dsl/app/DSL.hs b/dsl/app/DSL.hs index 79ff29b..2b68198 100644 --- a/dsl/app/DSL.hs +++ b/dsl/app/DSL.hs @@ -2,15 +2,27 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, NoFieldSelectors, OverloadedRecordDot, DuplicateRecordFields #-} -module DSL (parseSubStageDef, SubStage) where +module DSL ( + parseSubStageDef, + SubStage (..), + Head (..), + Body (..), + When (..), + Literal (..), + Variable (..), + Conjunction (..), + Predicate (..) + ) 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] @@ -29,11 +41,17 @@ module DSL (parseSubStageDef, SubStage) where data When = Always | Fulfilled | Unfulfilled deriving Show data Body = Body { - variables :: [Variable], + variables :: Map String Variable, dnf :: [Conjunction] } deriving Show - data Variable = Single String Literal | Block String Conjunction deriving Show + data Variable = Single { + id :: String, + lit :: Literal + } | Block { + id :: String, + conj :: Conjunction + } deriving Show type Conjunction = [Literal] @@ -113,11 +131,11 @@ module DSL (parseSubStageDef, SubStage) where parseBody :: Parsec BSL.ByteString u Body - parseBody = toBody ([], []) <$> bodyContentParser + parseBody = toBody (empty, []) <$> bodyContentParser where - toBody :: ([Variable], [Conjunction]) -> [Either Variable Conjunction] -> Body + toBody :: (Map String 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) ((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))) @@ -155,10 +173,10 @@ module DSL (parseSubStageDef, SubStage) where <|> (PreviousNodes <$> (string "previous_nodes" *> roundBrackets (try (squareBrackets parseLogVars) <|> parseLogVars))) - parseLogVar :: Parsec BSL.ByteString u String + parseLogVar :: Parsec BSL.ByteString u LogVar parseLogVar = (:) <$> alphaNum <*> many (try alphaNum <|> oneOf ['-', '_']) - parseLogVars :: Parsec BSL.ByteString u [String] + parseLogVars :: Parsec BSL.ByteString u [LogVar] parseLogVars = try ((:) <$> parseLogVar <*> many (spaces *> char ',' *> spaces *> parseLogVar)) <|> (spaces $> []) diff --git a/dsl/app/Main.hs b/dsl/app/DSLMain.hs similarity index 97% rename from dsl/app/Main.hs rename to dsl/app/DSLMain.hs index 4972561..a196919 100644 --- a/dsl/app/Main.hs +++ b/dsl/app/DSLMain.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -module Main where +module DSLMain where import DSL (parseSubStageDef) import Data.ByteString.Lazy.UTF8 as BSLU diff --git a/dsl/app/Transpiler.hs b/dsl/app/Transpiler.hs new file mode 100644 index 0000000..3110e16 --- /dev/null +++ b/dsl/app/Transpiler.hs @@ -0,0 +1,122 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# 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 Control.Monad.State (State, evalState, get, put, unless, when) + import Data.Map (Map, empty) + import qualified Data.Map as M + import Control.Monad.Except (ExceptT, runExceptT, throwError) + import Data.Either (fromLeft) + import Data.Maybe (fromJust, isNothing) + + + data ResolvedLiteral = Pred' { pred :: Predicate } + | Neg' { pred :: Predicate } deriving Show + + data DNFLiteral = DNFLit { + anchor :: AnchorData, + literal :: ResolvedLiteral + } + + type DNF = [[DNFLiteral]] + + instance ToYAML SubStage where + toYAML(SubStage 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) ] + ] + + newtype ResolveError = ResolveError String + + 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) + + resolve :: Body -> Either ResolveError DNF + resolve body = evalState (runExceptT (eval body)) initState + where + initState = StateData empty (M.map (, False) body.variables) [] + + eval :: Body -> Resolver DNF + eval (Body variables []) = get >>= \s -> return s.disjunction + eval (Body variables (c:dnf)) = do + conjunction <- evalConjunction c [] + state <- get + put $ state {innerVariables = empty, disjunction = conjunction : state.disjunction} + eval $ Body variables dnf + where + evalConjunction :: Conjunction -> [DNFLiteral] -> Resolver [DNFLiteral] + evalConjunction [] acc = return acc + evalConjunction (l:ls) acc = do + lit <- evalLiteral l + case lit of + Left literal -> evalConjunction ls (literal : acc) + Right block -> evalConjunction ls (block ++ acc) -- Merge content of block conjunction variables + evalLiteral :: Literal -> Resolver (Either DNFLiteral [DNFLiteral]) + evalLiteral n@(Neg _) = Left <$> evalNegation n + evalLiteral p@(Pred _) = Left <$> evalPredicate p + evalLiteral v@(Var _) = evalVariable False v + evalNegation :: Literal -> Resolver DNFLiteral -- Resolves redundant negations, e.g. `not not x` and also `let x = not y; let z = not x` + evalNegation (Neg n) = do + let (lit, count) = countNot 1 n + lit' <- case lit of { + Pred _ -> evalPredicate lit; + Var _ -> evalVariable True lit >>= \l -> return $ fromLeft (error "Preventing negated blocks failed") l; + Neg _ -> throwError . ResolveError $ "Could not resolve negation of: " ++ show n; + } + if even count then return lit' else do + let sign = case lit'.literal of { + Neg' _ -> Pred'; + Pred' _ -> Neg'; + } + return lit' { literal = sign lit'.literal.pred } + evalNegation x = throwError . ResolveError $ "Wrongfully labelt as negation: " ++ show x + countNot :: Word -> Literal -> (Literal, Word) + countNot x (Neg n) = countNot (x+1) n + countNot x lit = (lit, x) + evalPredicate :: Literal -> Resolver DNFLiteral + evalPredicate (Pred (EdgesInHistory _)) = undefined + evalPredicate (Pred (NodesInHistory _)) = undefined + evalPredicate (Pred (PayloadsFilled _)) = undefined + evalPredicate (Pred (PreviousNodes _)) = undefined + evalPredicate (Pred p) = return $ DNFLit { anchor = NoAnchor, literal = Pred' p } + evalPredicate x = throwError . ResolveError $ "Wrongfully labelt as predicate: " ++ show x + 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 [] + 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 diff --git a/dsl/dsl.cabal b/dsl/dsl.cabal deleted file mode 100644 index 2a6da7f..0000000 --- a/dsl/dsl.cabal +++ /dev/null @@ -1,38 +0,0 @@ -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/workflow-visualiser.cabal b/workflow-visualiser.cabal index ad349d9..692ffd1 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -28,7 +28,10 @@ executable workflow-visualiser other-modules: Workflow, Export, Index, - YamlParser + YamlParser, + DSLMain, + DSL, + Transpiler -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -41,6 +44,8 @@ executable workflow-visualiser vector, directory, regex-tdfa, - mtl - hs-source-dirs: app + mtl, + parsec, + utf8-string + hs-source-dirs: app, dsl/app default-language: Haskell2010