diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,6 +4,8 @@ A Haskell implementation of Katydid. +![Katydid Logo](https://cdn.rawgit.com/katydid/katydid.github.io/master/logo.png) + This includes: - [Relapse](https://katydid.github.io/katydid-haskell/Relapse.html): Validation Language @@ -17,13 +19,13 @@ All JSON and XML tests from [the language agnostic test suite](https://github.com/katydid/testsuite) [passes]. -[Hackage](https://hackage.haskell.org/package/katydid-0.1.0.0). +[Hackage](https://hackage.haskell.org/package/katydid-0.1.0.0) ## Example Validating a single structure can be done using the validate function: ```haskell -validate :: Tree t => Refs -> [t] -> Bool +validate :: Tree t => Grammar -> [t] -> Bool ``` , where a tree is a class in the [Parsers](https://katydid.github.io/katydid-haskell/Parsers.html) module: @@ -42,7 +44,7 @@ else putStrLn "dragons are fictional" ) $ Relapse.validate <$> - runExcept (Relapse.parseGrammar ".DragonsExist == true") <*> + Relapse.parse ".DragonsExist == true" <*> Json.decodeJSON "{\"DragonsExist\": false}" ``` @@ -51,6 +53,52 @@ If you want to validate multiple trees using the same grammar then the filter function does some internal memoization, which makes a huge difference. ```haskell -filter :: Tree t => Refs -> [[t]] -> [[t]] +filter :: Tree t => Grammar -> [[t]] -> [[t]] ``` +## User Defined Functions + +If you want to create your own extra functions for operating on the leaves, +then you can inject them into the parse function: + +```haskell +main = either + (\err -> putStrLn $ "error:" ++ err) + (\valid -> if valid + then putStrLn "prime birthday !!!" + else putStrLn "JOMO" + ) $ + Relapse.validate <$> + Relapse.parseWithUDFs userLib ".Survived->isPrime($int)" <*> + Json.decodeJSON "{\"Survived\": 104743}" +``` + +Defining your own user library to inject is easy. +The `Expr` library provides many useful helper functions: + +```haskell +import Data.Numbers.Primes (isPrime) +import Expr + +userLib :: String -> [AnyExpr] -> Either String AnyExpr +userLib "isPrime" args = mkIsPrime args +userLib n _ = throwError $ "undefined function: " ++ n + +mkIsPrime :: [AnyExpr] -> Either String AnyExpr +mkIsPrime args = do { + arg <- assertArgs1 "isPrime" args; + mkBoolExpr . isPrimeExpr <$> assertInt arg; +} + +isPrimeExpr :: Integral a => Expr a -> Expr Bool +isPrimeExpr numExpr = trimBool Expr { + desc = mkDesc "isPrime" [desc numExpr] + , eval = \fieldValue -> isPrime <$> eval numExpr fieldValue +} +``` + +## Roadmap + + - Protobuf parser + - Profile and Optimize (bring up to par with Go version) + - Typed DSL (Combinator) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,6 @@ import qualified Relapse import qualified Json -import Control.Monad.Except (runExcept) main :: IO () main = either @@ -12,6 +11,6 @@ else putStrLn "dragons are fictional" ) $ Relapse.validate <$> - runExcept (Relapse.parseGrammar ".DragonsExist == true") <*> + Relapse.parse ".DragonsExist == true" <*> Json.decodeJSON "{\"DragonsExist\": false}" diff --git a/bench/Benchmarks.hs b/bench/Benchmarks.hs --- a/bench/Benchmarks.hs +++ b/bench/Benchmarks.hs @@ -6,8 +6,7 @@ main :: IO () main = do { benches <- readBenches; - benchmarks <- return $ map (\benchcase -> - B.bench (benchname benchcase) $ B.perBatchEnv (stretch benchcase) runBench - ) benches; - B.defaultMain benchmarks; + B.defaultMain $ map (\benchcase -> + B.bench (benchname benchcase) $ + B.perBatchEnv (stretch benchcase) runBench) benches; } diff --git a/katydid.cabal b/katydid.cabal --- a/katydid.cabal +++ b/katydid.cabal @@ -1,5 +1,5 @@ name: katydid -version: 0.2.0.1 +version: 0.3.0.0 synopsis: A haskell implementation of Katydid description: A haskell implementation of Katydid @@ -30,20 +30,29 @@ library hs-source-dirs: src - exposed-modules: Patterns + exposed-modules: Ast , Derive , MemDerive , Zip , IfExprs , Expr + , Exprs.Compare + , Exprs.Contains + , Exprs.Elem + , Exprs.Length + , Exprs.Logic + , Exprs.Strings + , Exprs.Type + , Exprs.Var + , Exprs , Simplify , Json , Xml , Parsers - , ParsePatterns , VpaDerive , Parser , Relapse + , Smart build-depends: base >= 4.7 && < 5 , containers , json @@ -52,6 +61,11 @@ , mtl , parsec , deepseq + , text + , bytestring + , either + , extra + , ilist default-language: Haskell2010 executable katydid-exe @@ -79,9 +93,14 @@ , mtl , tasty-hunit , tasty - other-modules: ParserSpec + , text + , primes + , ilist + other-modules: UserDefinedFuncs + , ParserSpec , RelapseSpec , Suite + , DeriveSpec ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Ast.hs b/src/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Ast.hs @@ -0,0 +1,117 @@ +-- | +-- This module describes the Relapse's abstract syntax tree. +-- +-- It also contains some simple functions for the map of references that a Relapse grammar consists of. +-- +-- Finally it also contains some very simple pattern functions. +module Ast ( + Pattern(..) + , Grammar, emptyRef, union, newRef, reverseLookupRef, lookupRef, hasRecursion, listRefs + , nullable +) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Control.Monad.Extra ((||^), (&&^)) + +import Expr + +-- | +-- Pattern recursively describes a Relapse Pattern. +data Pattern + = Empty + | ZAny + | Node (Expr Bool) Pattern + | Or Pattern Pattern + | And Pattern Pattern + | Not Pattern + | Concat Pattern Pattern + | Interleave Pattern Pattern + | ZeroOrMore Pattern + | Optional Pattern + | Contains Pattern + | Reference String + deriving (Eq, Ord, Show) + +-- | +-- The nullable function returns whether a pattern is nullable. +-- This means that the pattern matches the empty string. +nullable :: Grammar -> Pattern -> Either String Bool +nullable _ Empty = Right True +nullable _ ZAny = Right True +nullable _ Node{} = Right False +nullable g (Or l r) = nullable g l ||^ nullable g r +nullable g (And l r) = nullable g l &&^ nullable g r +nullable g (Not p) = not <$> nullable g p +nullable g (Concat l r) = nullable g l &&^ nullable g r +nullable g (Interleave l r) = nullable g l &&^ nullable g r +nullable _ (ZeroOrMore _) = Right True +nullable _ (Optional _) = Right True +nullable g (Contains p) = nullable g p +nullable g (Reference refName) = lookupRef g refName >>= nullable g + +-- | +-- Refs is a map from reference name to pattern and describes a relapse grammar. +newtype Grammar = Grammar (M.Map String Pattern) + deriving (Show, Eq) + +-- | +-- lookupRef looks up a pattern in the reference map, given a reference name. +lookupRef :: Grammar -> String -> Either String Pattern +lookupRef (Grammar m) refName = case M.lookup refName m of + Nothing -> Left $ "missing reference: " ++ refName + (Just p) -> Right p + +-- | +-- listRefs returns the list of reference names. +listRefs :: Grammar -> [String] +listRefs (Grammar m) = M.keys m + +-- | +-- reverseLookupRef returns the reference name for a given pattern. +reverseLookupRef :: Pattern -> Grammar -> Maybe String +reverseLookupRef p (Grammar m) = case M.keys $ M.filter (== p) m of + [] -> Nothing + (k:_) -> Just k + +-- | +-- newRef returns a new reference map given a single pattern and its reference name. +newRef :: String -> Pattern -> Grammar +newRef key value = Grammar $ M.singleton key value + +-- | +-- emptyRef returns an empty reference map. +emptyRef :: Grammar +emptyRef = Grammar M.empty + +-- | +-- union returns the union of two reference maps. +union :: Grammar -> Grammar -> Grammar +union (Grammar m1) (Grammar m2) = Grammar $ M.union m1 m2 + +-- | +-- hasRecursion returns whether an relapse grammar has any recursion, starting from the "main" reference. +hasRecursion :: Grammar -> Either String Bool +hasRecursion g = do { + mainPat <- lookupRef g "main"; + hasRec g (S.singleton "main") mainPat +} + +hasRec :: Grammar -> S.Set String -> Pattern -> Either String Bool +hasRec _ _ Empty = Right False +hasRec _ _ ZAny = Right False +hasRec _ _ Node{} = Right False +hasRec g set (Or l r) = hasRec g set l ||^ hasRec g set r +hasRec g set (And l r) = hasRec g set l ||^ hasRec g set r +hasRec g set (Not p) = hasRec g set p +hasRec g set (Concat l r) = hasRec g set l ||^ (nullable g l &&^ hasRec g set r) +hasRec g set (Interleave l r) = hasRec g set l ||^ hasRec g set r +hasRec g set (ZeroOrMore p) = hasRec g set p +hasRec g set (Optional p) = hasRec g set p +hasRec g set (Contains p) = hasRec g set p +hasRec g set (Reference refName) = if S.member refName set + then Right True + else do { + pat <- lookupRef g refName; + hasRec g (S.insert refName set) pat; + } diff --git a/src/Derive.hs b/src/Derive.hs --- a/src/Derive.hs +++ b/src/Derive.hs @@ -9,13 +9,15 @@ module Derive ( derive, calls, returns, zipderive + -- * Internal functions + -- | These functions are exposed for testing purposes. + , removeOneForEach ) where import Data.Foldable (foldlM) -import Control.Monad.Except (Except, mapExcept, throwError) +import Data.List.Index (imap) -import Patterns -import Expr +import Smart import Parsers import Simplify import Zip @@ -32,111 +34,131 @@ -- -- , where the resulting list of patterns are the child patterns, -- that need to be derived given the trees child values. -calls :: Refs -> [Pattern] -> IfExprs -calls refs ps = compileIfExprs refs $ concatMap (\p -> deriveCall refs p []) ps +calls :: Grammar -> [Pattern] -> IfExprs +calls g ps = compileIfExprs $ concatMap (\p -> deriveCall g p []) ps -deriveCall :: Refs -> Pattern -> [IfExpr]-> [IfExpr] +deriveCall :: Grammar -> Pattern -> [IfExpr] -> [IfExpr] deriveCall _ Empty res = res deriveCall _ ZAny res = res -deriveCall _ (Node v p) res = (newIfExpr v p (Not ZAny)) : res -deriveCall refs (Concat l r) res - | nullable refs l = deriveCall refs l (deriveCall refs r res) - | otherwise = deriveCall refs l res -deriveCall refs (Or l r) res = deriveCall refs l (deriveCall refs r res) -deriveCall refs (And l r) res = deriveCall refs l (deriveCall refs r res) -deriveCall refs (Interleave l r) res = deriveCall refs l (deriveCall refs r res) -deriveCall refs (ZeroOrMore p) res = deriveCall refs p res -deriveCall refs (Reference name) res = deriveCall refs (lookupRef refs name) res -deriveCall refs (Not p) res = deriveCall refs p res -deriveCall refs (Contains p) res = deriveCall refs (Concat ZAny (Concat p ZAny)) res -deriveCall refs (Optional p) res = deriveCall refs (Or p Empty) res +deriveCall _ Node{expr=v,pat=p} res = newIfExpr v p emptySet : res +deriveCall g Concat{left=l,right=r} res + | nullable l = deriveCall g l (deriveCall g r res) + | otherwise = deriveCall g l res +deriveCall g Or{pats=ps} res = foldr (deriveCall g) res ps +deriveCall g And{pats=ps} res = foldr (deriveCall g) res ps +deriveCall g Interleave{pats=ps} res = foldr (deriveCall g) res ps +deriveCall g ZeroOrMore{pat=p} res = deriveCall g p res +deriveCall g Reference{refName=name} res = deriveCall g (lookupRef g name) res +deriveCall g Not{pat=p} res = deriveCall g p res +deriveCall g Contains{pat=p} res = deriveCall g p res +deriveCall g Optional{pat=p} res = deriveCall g p res -- | -- returns takes a list of patterns and list of bools. -- The list of bools represent the nullability of the derived child patterns. -- Each bool will then replace each Node pattern with either an Empty or EmptySet. -- The lists do not to be the same length, because each Pattern can contain an arbitrary number of Node Patterns. -returns :: Refs -> ([Pattern], [Bool]) -> [Pattern] +returns :: Grammar -> ([Pattern], [Bool]) -> [Pattern] returns _ ([], []) = [] -returns refs (p:tailps, ns) = - let (dp, tailns) = deriveReturn refs p ns - sp = simplify refs dp - in sp:returns refs (tailps, tailns) +returns g (p:tailps, ns) = + let (dp, tailns) = deriveReturn g p ns + in dp:returns g (tailps, tailns) -deriveReturn :: Refs -> Pattern -> [Bool] -> (Pattern, [Bool]) -deriveReturn _ Empty ns = (Not ZAny, ns) -deriveReturn _ ZAny ns = (ZAny, ns) -deriveReturn _ Node{} ns - | head ns = (Empty, tail ns) - | otherwise = (Not ZAny, tail ns) -deriveReturn refs (Concat l r) ns - | nullable refs l = - let (leftDeriv, leftTail) = deriveReturn refs l ns - (rightDeriv, rightTail) = deriveReturn refs r leftTail - in (Or (Concat leftDeriv r) rightDeriv, rightTail) - | otherwise = - let (leftDeriv, leftTail) = deriveReturn refs l ns - in (Concat leftDeriv r, leftTail) -deriveReturn refs (Or l r) ns = - let (leftDeriv, leftTail) = deriveReturn refs l ns - (rightDeriv, rightTail) = deriveReturn refs r leftTail - in (Or leftDeriv rightDeriv, rightTail) -deriveReturn refs (And l r) ns = - let (leftDeriv, leftTail) = deriveReturn refs l ns - (rightDeriv, rightTail) = deriveReturn refs r leftTail - in (And leftDeriv rightDeriv, rightTail) -deriveReturn refs (Interleave l r) ns = - let (leftDeriv, leftTail) = deriveReturn refs l ns - (rightDeriv, rightTail) = deriveReturn refs r leftTail - in (Or (Interleave leftDeriv r) (Interleave rightDeriv l), rightTail) -deriveReturn refs z@(ZeroOrMore p) ns = - let (derivp, tailns) = deriveReturn refs p ns - in (Concat derivp z, tailns) -deriveReturn refs (Reference name) ns = deriveReturn refs (lookupRef refs name) ns -deriveReturn refs (Not p) ns = - let (derivp, tailns) = deriveReturn refs p ns - in (Not derivp, tailns) -deriveReturn refs (Contains p) ns = deriveReturn refs (Concat ZAny (Concat p ZAny)) ns -deriveReturn refs (Optional p) ns = deriveReturn refs (Or p Empty) ns +mapReturn :: Grammar -> [Pattern] -> [Bool] -> ([Pattern], [Bool]) +mapReturn g ps ns = foldl (\(dps, tailns) p -> + let (dp, tailoftail) = deriveReturn g p tailns + in (dp:dps, tailoftail) + ) ([], ns) ps -onePattern :: Either ValueErr [Pattern] -> Either String Pattern -onePattern (Right [r]) = return r -onePattern (Left e) = throwError $ show e -onePattern (Right rs) = throwError $ "Number of patterns is not one, but " ++ show rs +deriveReturn :: Grammar -> Pattern -> [Bool] -> (Pattern, [Bool]) +deriveReturn _ Empty ns = (emptySet, ns) +deriveReturn _ ZAny ns = (zanyPat, ns) +deriveReturn _ Node{} ns + | head ns = (emptyPat, tail ns) + | otherwise = (emptySet, tail ns) +deriveReturn g Concat{left=l,right=r} ns + | nullable l = + let (dl, ltail) = deriveReturn g l ns + (dr, rtail) = deriveReturn g r ltail + in (orPat (concatPat dl r) dr, rtail) + | otherwise = + let (dl, ltail) = deriveReturn g l ns + in (concatPat dl r, ltail) +deriveReturn g Or{pats=ps} ns = + let (dps, tailns) = mapReturn g ps ns + in (foldl1 orPat dps, tailns) +deriveReturn g And{pats=ps} ns = + let (dps, tailns) = mapReturn g ps ns + in (foldl1 andPat dps, tailns) +deriveReturn g Interleave{pats=ps} ns = + let (dps, tailns) = mapReturn g ps ns + pps = reverse $ removeOneForEach ps + ips = zipWith (:) dps pps + ors = map (foldl1 interleavePat) ips + in (foldl1 orPat ors, tailns) +deriveReturn g z@ZeroOrMore{pat=p} ns = + let (dp, tailns) = deriveReturn g p ns + in (concatPat dp z, tailns) +deriveReturn g Reference{refName=name} ns = deriveReturn g (lookupRef g name) ns +deriveReturn g Not{pat=p} ns = + let (dp, tailns) = deriveReturn g p ns + in (notPat dp, tailns) +deriveReturn g c@Contains{pat=p} ns = + let (dp, tailns) = deriveReturn g p ns + in (orPat c (containsPat dp), tailns) +deriveReturn g Optional{pat=p} ns = deriveReturn g p ns +-- | For internal testing. +-- removeOneForEach creates N copies of the list removing the n'th element from each. +removeOneForEach :: [a] -> [[a]] +removeOneForEach xs = imap (\index list -> + let (start,end) = splitAt index list + in start ++ tail end + ) (replicate (length xs) xs) + -- | -- derive is the classic derivative implementation for trees. -derive :: Tree t => Refs -> [t] -> Except String Pattern -derive g ts = mapExcept onePattern $ foldlM (deriv g) [lookupRef g "main"] ts +derive :: Tree t => Grammar -> [t] -> Either String Pattern +derive g ts = do { + ps <- foldlM (deriv g) [lookupMain g] ts; + if length ps == 1 + then return $ head ps + else Left $ "Number of patterns is not one, but " ++ show ps +} -deriv :: Tree t => Refs -> [Pattern] -> t -> Except ValueErr [Pattern] -deriv refs ps tree = +deriv :: Tree t => Grammar -> [Pattern] -> t -> Either String [Pattern] +deriv g ps tree = if all unescapable ps then return ps else - let ifs = calls refs ps - d = deriv refs - nulls = map (nullable refs) + let ifs = calls g ps + d = deriv g + nulls = map nullable in do { childps <- evalIfExprs ifs (getLabel tree); childres <- foldlM d childps (getChildren tree); - return $ returns refs (ps, nulls childres); + return $ returns g (ps, nulls childres); } -- | -- zipderive is a slighty optimized version of derivs. -- It zips its intermediate pattern lists to reduce the state space. -zipderive :: Tree t => Refs -> [t] -> Except String Pattern -zipderive g ts = mapExcept onePattern $ foldlM (zipderiv g) [lookupRef g "main"] ts +zipderive :: Tree t => Grammar -> [t] -> Either String Pattern +zipderive g ts = do { + ps <- foldlM (zipderiv g) [lookupMain g] ts; + if length ps == 1 + then return $ head ps + else Left $ "Number of patterns is not one, but " ++ show ps +} -zipderiv :: Tree t => Refs -> [Pattern] -> t -> Except ValueErr [Pattern] -zipderiv refs ps tree = +zipderiv :: Tree t => Grammar -> [Pattern] -> t -> Either String [Pattern] +zipderiv g ps tree = if all unescapable ps then return ps else - let ifs = calls refs ps - d = zipderiv refs - nulls = map (nullable refs) + let ifs = calls g ps + d = zipderiv g + nulls = map nullable in do { childps <- evalIfExprs ifs (getLabel tree); (zchildps, zipper) <- return $ zippy childps; childres <- foldlM d zchildps (getChildren tree); let unzipns = unzipby zipper (nulls childres) - in return $ returns refs (ps, unzipns) + in return $ returns g (ps, unzipns) } diff --git a/src/Expr.hs b/src/Expr.hs --- a/src/Expr.hs +++ b/src/Expr.hs @@ -1,518 +1,513 @@ -{-#LANGUAGE GADTs, StandaloneDeriving #-} - -- | --- This module contains all the Relapse expressions. --- --- It also contains an eval function and a simplfication function for these expressions. +-- This module contains all the functions you need to implement a Relapse expression. + module Expr ( - -- * Expressions - Expr(..), Bytes, Uint, - -- * Functions - simplifyBoolExpr, eval, - -- * Errors - ValueErr + Desc(..), mkDesc + , AnyExpr(..), AnyFunc(..) + , Expr(..), Func, params, name, hasVar + , hashWithName, hashList, hashString + , evalConst, isConst + , assertArgs1, assertArgs2 + , mkBoolExpr, mkIntExpr, mkStringExpr, mkDoubleExpr, mkBytesExpr, mkUintExpr + , assertBool, assertInt, assertString, assertDouble, assertBytes, assertUint + , boolExpr, intExpr, stringExpr, doubleExpr, bytesExpr, uintExpr + , trimBool, trimInt, trimString, trimDouble, trimBytes, trimUint + , mkBoolsExpr, mkIntsExpr, mkStringsExpr, mkDoublesExpr, mkListOfBytesExpr, mkUintsExpr + , assertBools, assertInts, assertStrings, assertDoubles, assertListOfBytes, assertUints + , boolsExpr, intsExpr, stringsExpr, doublesExpr, listOfBytesExpr, uintsExpr ) where -import Data.List (isInfixOf, isPrefixOf, isSuffixOf) -import Data.Char (toLower, toUpper) -import Text.Regex.TDFA ((=~)) -import Control.Monad.Except (Except, runExcept, throwError) - -import Parsers - -type Bytes = String -type Uint = Int - -data Expr a where - -- Expr Bool - - Const :: a -> Expr a - BoolVariable :: Expr Bool - - OrFunc :: Expr Bool -> Expr Bool -> Expr Bool - AndFunc :: Expr Bool -> Expr Bool -> Expr Bool - NotFunc :: Expr Bool -> Expr Bool - - BoolEqualFunc :: Expr Bool -> Expr Bool -> Expr Bool - DoubleEqualFunc :: Expr Double -> Expr Double -> Expr Bool - IntEqualFunc :: Expr Int -> Expr Int -> Expr Bool - UintEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool - StringEqualFunc :: Expr String -> Expr String -> Expr Bool - BytesEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool - - IntListContainsFunc :: Expr Int -> [Expr Int] -> Expr Bool - StringListContainsFunc :: Expr String -> [Expr String] -> Expr Bool - UintListContainsFunc :: Expr Uint -> [Expr Uint] -> Expr Bool - StringContainsFunc :: Expr String -> Expr String -> Expr Bool - - BoolListElemFunc :: [Expr Bool] -> Expr Int -> Expr Bool - - BytesGreaterOrEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool - DoubleGreaterOrEqualFunc :: Expr Double -> Expr Double -> Expr Bool - IntGreaterOrEqualFunc :: Expr Int -> Expr Int -> Expr Bool - UintGreaterOrEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool - - BytesGreaterThanFunc :: Expr Bytes -> Expr Bytes -> Expr Bool - DoubleGreaterThanFunc :: Expr Double -> Expr Double -> Expr Bool - IntGreaterThanFunc :: Expr Int -> Expr Int -> Expr Bool - UintGreaterThanFunc :: Expr Uint -> Expr Uint -> Expr Bool - - StringHasPrefixFunc :: Expr String -> Expr String -> Expr Bool - StringHasSuffixFunc :: Expr String -> Expr String -> Expr Bool - - BytesLessOrEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool - DoubleLessOrEqualFunc :: Expr Double -> Expr Double -> Expr Bool - IntLessOrEqualFunc :: Expr Int -> Expr Int -> Expr Bool - UintLessOrEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool - - BytesLessThanFunc :: Expr Bytes -> Expr Bytes -> Expr Bool - DoubleLessThanFunc :: Expr Double -> Expr Double -> Expr Bool - IntLessThanFunc :: Expr Int -> Expr Int -> Expr Bool - UintLessThanFunc :: Expr Uint -> Expr Uint -> Expr Bool - - BytesNotEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool - BoolNotEqualFunc :: Expr Bool -> Expr Bool -> Expr Bool - DoubleNotEqualFunc :: Expr Double -> Expr Double -> Expr Bool - IntNotEqualFunc :: Expr Int -> Expr Int -> Expr Bool - StringNotEqualFunc :: Expr String -> Expr String -> Expr Bool - UintNotEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool - - BytesTypeFunc :: Expr Bytes -> Expr Bool - BoolTypeFunc :: Expr Bool -> Expr Bool - DoubleTypeFunc :: Expr Double -> Expr Bool - IntTypeFunc :: Expr Int -> Expr Bool - UintTypeFunc :: Expr Uint -> Expr Bool - StringTypeFunc :: Expr String -> Expr Bool - - RegexFunc :: Expr String -> Expr String -> Expr Bool - - -- Expr Double - - DoubleVariable :: Expr Double - - DoubleListElemFunc :: [Expr Double] -> Expr Int -> Expr Double - - -- Expr Int - - IntVariable :: Expr Int - - IntListElemFunc :: [Expr Int] -> Expr Int -> Expr Int - - BytesListLengthFunc :: [Expr Bytes] -> Expr Int - BoolListLengthFunc :: [Expr Bool] -> Expr Int - BytesLengthFunc :: Expr Bytes -> Expr Int - DoubleListLengthFunc :: [Expr Double] -> Expr Int - IntListLengthFunc :: [Expr Int] -> Expr Int - StringListLengthFunc :: [Expr String] -> Expr Int - UintListLengthFunc :: [Expr Uint] -> Expr Int - StringLengthFunc :: Expr String -> Expr Int - - -- Expr Uint - - UintVariable :: Expr Uint - - UintListElemFunc :: [Expr Uint] -> Expr Int -> Expr Uint - - -- Expr String - - StringVariable :: Expr String - StringListElemFunc :: [Expr String] -> Expr Int -> Expr String - StringToLowerFunc :: Expr String -> Expr String - StringToUpperFunc :: Expr String -> Expr String - - -- Expr Bytes - - BytesVariable :: Expr Bytes - - BytesListElemFunc :: [Expr Bytes] -> Expr Int -> Expr Bytes - -deriving instance Eq a => Eq (Expr a) -deriving instance Ord a => Ord (Expr a) -deriving instance Show a => Show (Expr a) +import Data.Char (ord) +import Data.List (intercalate) +import Data.Text (Text, unpack, pack) +import Data.ByteString (ByteString) -data ValueErr - = ErrNotABool String - | ErrNotAString String - | ErrNotAnInt String - | ErrNotADouble String - | ErrNotAnUint String - | ErrNotBytes String - deriving (Eq, Ord, Show) +import qualified Parsers -- | --- eval evaluates a boolean expression, given an input label. -eval :: Expr Bool -> Label -> Except ValueErr Bool -eval = ev - -ev :: Expr a -> Label -> Except ValueErr a +-- assertArgs1 asserts that the list of arguments is only one argument and +-- returns the argument or an error message +-- containing the function name that was passed in as an argument to assertArgs1. +assertArgs1 :: String -> [AnyExpr] -> Either String AnyExpr +assertArgs1 _ [e1] = Right e1 +assertArgs1 exprName es = Left $ exprName ++ ": expected one argument, but got " ++ show (length es) ++ ": " ++ show es -ev (Const b) _ = return b -ev BoolVariable (Bool b) = return b -ev BoolVariable l = throwError $ ErrNotABool $ show l +-- | +-- assertArgs2 asserts that the list of arguments is only two arguments and +-- returns the two arguments or an error message +-- containing the function name that was passed in as an argument to assertArgs2. +assertArgs2 :: String -> [AnyExpr] -> Either String (AnyExpr, AnyExpr) +assertArgs2 _ [e1, e2] = Right (e1, e2) +assertArgs2 exprName es = Left $ exprName ++ ": expected two arguments, but got " ++ show (length es) ++ ": " ++ show es -ev (OrFunc e1 e2) v = (||) <$> ev e1 v <*> ev e2 v +-- | +-- Desc is the description of a function, +-- especially built to make comparisons of user defined expressions possible. +data Desc = Desc { + _name :: String + , _toStr :: String + , _hash :: Int + , _params :: [Desc] + , _hasVar :: Bool +} -ev (AndFunc e1 e2) v = (&&) <$> ev e1 v <*> ev e2 v +-- | +-- mkDesc makes a description from a function name and a list of the argument's descriptions. +mkDesc :: String -> [Desc] -> Desc +mkDesc n ps = Desc { + _name = n + , _toStr = n ++ "(" ++ intercalate "," (map show ps) ++ ")" + , _hash = hashWithName n ps + , _params = ps + , _hasVar = any _hasVar ps +} -ev (NotFunc e) v = case runExcept $ ev e v of - (Right True) -> return False - _ -> return True +instance Show Desc where + show = _toStr -ev (BoolEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (DoubleEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (IntEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (UintEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (StringEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (BytesEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v) +instance Ord Desc where + compare = cmp -ev (IntListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es +instance Eq Desc where + (==) a b = cmp a b == EQ -ev (StringListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es +-- | +-- AnyExpr is used by the Relapse parser to represent an Expression that can return any type of value, +-- where any is a predefined list of possible types represented by AnyFunc. +data AnyExpr = AnyExpr { + _desc :: Desc + , _eval :: AnyFunc +} -ev (UintListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es +-- | +-- Func represents the evaluation function part of a user defined expression. +-- This function takes a label from a tree parser and returns a value or an error string. +type Func a = (Parsers.Label -> Either String a) -ev (StringContainsFunc s sub) v = isInfixOf <$> ev sub v <*> ev s v +instance Show AnyExpr where + show a = show (_desc a) -ev (BoolListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v +instance Eq AnyExpr where + (==) a b = _desc a == _desc b -ev (DoubleGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (IntGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (UintGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (BytesGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v) +instance Ord AnyExpr where + compare a b = cmp (_desc a) (_desc b) -ev (DoubleGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (IntGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (UintGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (BytesGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v) +-- | +-- AnyFunc is used by the Relapse parser and represents the list all supported types of functions. +data AnyFunc = BoolFunc (Func Bool) + | IntFunc (Func Int) + | StringFunc (Func Text) + | DoubleFunc (Func Double) + | UintFunc (Func Word) + | BytesFunc (Func ByteString) + | BoolsFunc (Func [Bool]) + | IntsFunc (Func [Int]) + | StringsFunc (Func [Text]) + | DoublesFunc (Func [Double]) + | UintsFunc (Func [Word]) + | ListOfBytesFunc (Func [ByteString]) -ev (StringHasPrefixFunc e1 e2) v = isPrefixOf <$> ev e2 v <*> ev e1 v +-- | +-- Expr represents a user defined expression, +-- which consists of a description for comparisons and an evaluation function. +data Expr a = Expr { + desc :: Desc + , eval :: Func a +} -ev (StringHasSuffixFunc e1 e2) v = isSuffixOf <$> ev e2 v <*> ev e1 v +instance Show (Expr a) where + show e = show (desc e) -ev (DoubleLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (IntLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (UintLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (BytesLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v) +instance Eq (Expr a) where + (==) x y = desc x == desc y -ev (DoubleLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (IntLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (UintLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (BytesLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v) +instance Ord (Expr a) where + compare x y = cmp (desc x) (desc y) -ev (BoolNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (DoubleNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (IntNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (UintNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (StringNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v) -ev (BytesNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v) +-- | +-- params returns the descriptions of the parameters of the user defined expression. +params :: Expr a -> [Desc] +params = _params . desc -ev (BytesTypeFunc e) v = case runExcept $ ev e v of - (Right _) -> return True - (Left _) -> return False -ev (BoolTypeFunc e) v = case runExcept $ ev e v of - (Right _) -> return True - (Left _) -> return False -ev (DoubleTypeFunc e) v = case runExcept $ ev e v of - (Right _) -> return True - (Left _) -> return False -ev (IntTypeFunc e) v = case runExcept $ ev e v of - (Right _) -> return True - (Left _) -> return False -ev (UintTypeFunc e) v = case runExcept $ ev e v of - (Right _) -> return True - (Left _) -> return False -ev (StringTypeFunc e) v = case runExcept $ ev e v of - (Right _) -> return True - (Left _) -> return False +-- | +-- name returns the name of the user defined expression. +name :: Expr a -> String +name = _name . desc -ev (RegexFunc e s) v = (=~) <$> ev s v <*> ev e v +-- | +-- hasVar returns whether the expression or any of its children contains a variable expression. +hasVar :: Expr a -> Bool +hasVar = _hasVar . desc -ev DoubleVariable (Number r) = return $ fromRational r -ev DoubleVariable l = throwError $ ErrNotADouble $ show l +-- | +-- mkBoolExpr generalises a bool expression to any expression. +mkBoolExpr :: Expr Bool -> AnyExpr +mkBoolExpr (Expr desc eval) = AnyExpr desc (BoolFunc eval) -ev (DoubleListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v +-- | +-- assertBool asserts that any expression is actually a bool expression. +assertBool :: AnyExpr -> Either String (Expr Bool) +assertBool (AnyExpr desc (BoolFunc eval)) = Right $ Expr desc eval +assertBool (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bool" -ev IntVariable (Number r) = return (truncate r) -ev IntVariable l = throwError $ ErrNotAnInt $ show l +-- | +-- mkIntExpr generalises an int expression to any expression. +mkIntExpr :: Expr Int -> AnyExpr +mkIntExpr (Expr desc eval) = AnyExpr desc (IntFunc eval) -ev (IntListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v +-- | +-- assertInt asserts that any expression is actually an int expression. +assertInt :: AnyExpr -> Either String (Expr Int) +assertInt (AnyExpr desc (IntFunc eval)) = Right $ Expr desc eval +assertInt (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type int" -ev (BytesListLengthFunc es) v = length <$> mapM (`ev` v) es +-- | +-- mkDoubleExpr generalises a double expression to any expression. +mkDoubleExpr :: Expr Double -> AnyExpr +mkDoubleExpr (Expr desc eval) = AnyExpr desc (DoubleFunc eval) -ev (BoolListLengthFunc es) v = length <$> mapM (`ev` v) es +-- | +-- assertDouble asserts that any expression is actually a double expression. +assertDouble :: AnyExpr -> Either String (Expr Double) +assertDouble (AnyExpr desc (DoubleFunc eval)) = Right $ Expr desc eval +assertDouble (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type double" -ev (BytesLengthFunc e) v = length <$> ev e v +-- | +-- mkStringExpr generalises a string expression to any expression. +mkStringExpr :: Expr Text -> AnyExpr +mkStringExpr (Expr desc eval) = AnyExpr desc (StringFunc eval) -ev (DoubleListLengthFunc es) v = length <$> mapM (`ev` v) es +-- | +-- assertString asserts that any expression is actually a string expression. +assertString :: AnyExpr -> Either String (Expr Text) +assertString (AnyExpr desc (StringFunc eval)) = Right $ Expr desc eval +assertString (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type string" -ev (IntListLengthFunc es) v = length <$> mapM (`ev` v) es +-- | +-- mkUintExpr generalises a uint expression to any expression. +mkUintExpr :: Expr Word -> AnyExpr +mkUintExpr (Expr desc eval) = AnyExpr desc (UintFunc eval) -ev (StringListLengthFunc es) v = length <$> mapM (`ev` v) es +-- | +-- assertUint asserts that any expression is actually a uint expression. +assertUint :: AnyExpr -> Either String (Expr Word) +assertUint (AnyExpr desc (UintFunc eval)) = Right $ Expr desc eval +assertUint (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type uint" -ev (UintListLengthFunc es) v = length <$> mapM (`ev` v) es +-- | +-- mkBytesExpr generalises a bytes expression to any expression. +mkBytesExpr :: Expr ByteString -> AnyExpr +mkBytesExpr (Expr desc eval) = AnyExpr desc (BytesFunc eval) -ev (StringLengthFunc e) v = length <$> ev e v +-- | +-- assertBytes asserts that any expression is actually a bytes expression. +assertBytes :: AnyExpr -> Either String (Expr ByteString) +assertBytes (AnyExpr desc (BytesFunc eval)) = Right $ Expr desc eval +assertBytes (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bytes" -ev UintVariable (Number r) = return $ truncate r -ev UintVariable l = throwError $ ErrNotAnUint $ show l +-- | +-- mkBoolsExpr generalises a list of bools expression to any expression. +mkBoolsExpr :: Expr [Bool] -> AnyExpr +mkBoolsExpr (Expr desc eval) = AnyExpr desc (BoolsFunc eval) -ev (UintListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v +-- | +-- assertBools asserts that any expression is actually a list of bools expression. +assertBools :: AnyExpr -> Either String (Expr [Bool]) +assertBools (AnyExpr desc (BoolsFunc eval)) = Right $ Expr desc eval +assertBools (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bools" -ev StringVariable (String s) = return s -ev StringVariable l = throwError $ ErrNotAString $ show l +-- | +-- mkIntsExpr generalises a list of ints expression to any expression. +mkIntsExpr :: Expr [Int] -> AnyExpr +mkIntsExpr (Expr desc eval) = AnyExpr desc (IntsFunc eval) -ev (StringListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v +-- | +-- assertInts asserts that any expression is actually a list of ints expression. +assertInts :: AnyExpr -> Either String (Expr [Int]) +assertInts (AnyExpr desc (IntsFunc eval)) = Right $ Expr desc eval +assertInts (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type ints" -ev (StringToLowerFunc s) v = map toLower <$> ev s v +-- | +-- mkUintsExpr generalises a list of uints expression to any expression. +mkUintsExpr :: Expr [Word] -> AnyExpr +mkUintsExpr (Expr desc eval) = AnyExpr desc (UintsFunc eval) -ev (StringToUpperFunc s) v = map toUpper <$> ev s v +-- | +-- assertUints asserts that any expression is actually a list of uints expression. +assertUints :: AnyExpr -> Either String (Expr [Word]) +assertUints (AnyExpr desc (UintsFunc eval)) = Right $ Expr desc eval +assertUints (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type uints" -ev BytesVariable (String s) = return s -ev BytesVariable l = throwError $ ErrNotBytes $ show l +-- | +-- mkDoublesExpr generalises a list of doubles expression to any expression. +mkDoublesExpr :: Expr [Double] -> AnyExpr +mkDoublesExpr (Expr desc eval) = AnyExpr desc (DoublesFunc eval) -ev (BytesListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v +-- | +-- assertDoubles asserts that any expression is actually a list of doubles expression. +assertDoubles :: AnyExpr -> Either String (Expr [Double]) +assertDoubles (AnyExpr desc (DoublesFunc eval)) = Right $ Expr desc eval +assertDoubles (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type doubles" -eq :: (Eq a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool -eq (Right v1) (Right v2) = return $ v1 == v2 -eq (Left _) _ = return False -eq _ (Left _) = return False +-- | +-- mkStringsExpr generalises a list of strings expression to any expression. +mkStringsExpr :: Expr [Text] -> AnyExpr +mkStringsExpr (Expr desc eval) = AnyExpr desc (StringsFunc eval) -ge :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool -ge (Right v1) (Right v2) = return $ v1 >= v2 -ge (Left _) _ = return False -ge _ (Left _) = return False +-- | +-- assertStrings asserts that any expression is actually a list of strings expression. +assertStrings :: AnyExpr -> Either String (Expr [Text]) +assertStrings (AnyExpr desc (StringsFunc eval)) = Right $ Expr desc eval +assertStrings (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type strings" -gt :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool -gt (Right v1) (Right v2) = return $ v1 > v2 -gt (Left _) _ = return False -gt _ (Left _) = return False +-- | +-- mkListOfBytesExpr generalises a list of bytes expression to any expression. +mkListOfBytesExpr :: Expr [ByteString] -> AnyExpr +mkListOfBytesExpr (Expr desc eval) = AnyExpr desc (ListOfBytesFunc eval) -le :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool -le (Right v1) (Right v2) = return $ v1 <= v2 -le (Left _) _ = return False -le _ (Left _) = return False +-- | +-- assertListOfBytes asserts that any expression is actually a list of bytes expression. +assertListOfBytes :: AnyExpr -> Either String (Expr [ByteString]) +assertListOfBytes (AnyExpr desc (ListOfBytesFunc eval)) = Right $ Expr desc eval +assertListOfBytes (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bytes" -lt :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool -lt (Right v1) (Right v2) = return $ v1 < v2 -lt (Left _) _ = return False -lt _ (Left _) = return False +(<>) :: Ordering -> Ordering -> Ordering +(<>) EQ c = c +(<>) c _ = c -ne :: (Eq a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool -ne (Right v1) (Right v2) = return $ v1 /= v2 -ne (Left _) _ = return False -ne _ (Left _) = return False +-- cmp is an efficient comparison function for expressions. +-- It is very important that cmp is efficient, +-- because it is a bottleneck for simplification and smart construction of large queries. +cmp :: Desc -> Desc -> Ordering +cmp a b = compare (_hash a) (_hash b) <> + compare (_name a) (_name b) <> + compare (length (_params a)) (length (_params b)) <> + foldl (<>) EQ (zipWith cmp (_params a) (_params b)) <> + compare (_toStr a) (_toStr b) -- | --- simplifyBoolExpr returns an equivalent, but simpler version of the input boolean expression. -simplifyBoolExpr :: Expr Bool -> Expr Bool -simplifyBoolExpr = simplifyExpr - -simplifyExpr :: Expr a -> Expr a -simplifyExpr (BoolEqualFunc (Const b1) (Const b2)) = Const $ b1 == b2 -simplifyExpr v@(Const _) = v -simplifyExpr v@BoolVariable = v - -simplifyExpr (OrFunc v1 v2) = simplifyOrFunc (simplifyExpr v1) (simplifyExpr v2) -simplifyExpr (AndFunc v1 v2) = simplifyAndFunc (simplifyExpr v1) (simplifyExpr v2) -simplifyExpr (NotFunc v) = simplifyNotFunc (simplifyExpr v) +-- hashWithName calculates a hash of the function name and its parameters. +hashWithName :: String -> [Desc] -> Int +hashWithName s ds = hashList (31*17 + hashString s) (map _hash ds) -simplifyExpr (BoolEqualFunc e1 e2) = BoolEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (DoubleEqualFunc e1 e2) = DoubleEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (IntEqualFunc e1 e2) = IntEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (UintEqualFunc e1 e2) = UintEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (StringEqualFunc e1 e2) = StringEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (BytesEqualFunc e1 e2) = BytesEqualFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- hashString calcuates a hash of a string. +hashString :: String -> Int +hashString s = hashList 0 (map ord s) -simplifyExpr (IntListContainsFunc e es) = IntListContainsFunc (simplifyExpr e) (map simplifyExpr es) -simplifyExpr (StringListContainsFunc e es) = StringListContainsFunc (simplifyExpr e) (map simplifyExpr es) -simplifyExpr (UintListContainsFunc e es) = UintListContainsFunc (simplifyExpr e) (map simplifyExpr es) -simplifyExpr (StringContainsFunc e1 e2) = StringContainsFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- hashList folds a list of hashes into one, given a seed and the list. +hashList :: Int -> [Int] -> Int +hashList = foldl (\acc h -> 31*acc + h) -simplifyExpr (BoolListElemFunc es e) = BoolListElemFunc (map simplifyExpr es) (simplifyExpr e) +noLabel :: Parsers.Label +noLabel = Parsers.String (pack "not a label, trying constant evaluation") -simplifyExpr (BytesGreaterOrEqualFunc e1 e2) = BytesGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (DoubleGreaterOrEqualFunc e1 e2) = DoubleGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (IntGreaterOrEqualFunc e1 e2) = IntGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (UintGreaterOrEqualFunc e1 e2) = UintGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- evalConst tries to evaluate a constant expression and +-- either returns the resulting constant value or nothing. +evalConst :: Expr a -> Maybe a +evalConst e = if hasVar e + then Nothing + else case eval e noLabel of + (Left _) -> Nothing + (Right v) -> Just v -simplifyExpr (BytesGreaterThanFunc e1 e2) = BytesGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (DoubleGreaterThanFunc e1 e2) = DoubleGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (IntGreaterThanFunc e1 e2) = IntGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (UintGreaterThanFunc e1 e2) = UintGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- isConst returns whether the input description is one of the six possible constant values. +isConst :: Desc -> Bool +isConst d = not (null (_params d)) && case _name d of + "bool" -> True + "int" -> True + "uint" -> True + "double" -> True + "string" -> True + "[]byte" -> True + _ -> False -simplifyExpr (StringHasPrefixFunc e1 e2) = StringHasPrefixFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (StringHasSuffixFunc e1 e2) = StringHasSuffixFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- boolExpr creates a constant bool expression from a input value. +boolExpr :: Bool -> Expr Bool +boolExpr b = Expr { + desc = Desc { + _name = "bool" + , _toStr = if b then "true" else "false" + , _hash = if b then 3 else 5 + , _params = [] + , _hasVar = False + } + , eval = const $ return b +} -simplifyExpr (BytesLessOrEqualFunc e1 e2) = BytesLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (DoubleLessOrEqualFunc e1 e2) = DoubleLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (IntLessOrEqualFunc e1 e2) = IntLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (UintLessOrEqualFunc e1 e2) = UintLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- intExpr creates a constant int expression from a input value. +intExpr :: Int -> Expr Int +intExpr i = Expr { + desc = Desc { + _name = "int" + , _toStr = show i + , _hash = i + , _params = [] + , _hasVar = False + } + , eval = const $ return i +} -simplifyExpr (BytesLessThanFunc e1 e2) = BytesLessThanFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (DoubleLessThanFunc e1 e2) = DoubleLessThanFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (IntLessThanFunc e1 e2) = IntLessThanFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (UintLessThanFunc e1 e2) = UintLessThanFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- doubleExpr creates a constant double expression from a input value. +doubleExpr :: Double -> Expr Double +doubleExpr d = Expr { + desc = Desc { + _name = "double" + , _toStr = show d + , _hash = truncate d + , _params = [] + , _hasVar = False + } + , eval = const $ return d +} -simplifyExpr (BoolNotEqualFunc e1 e2) = BoolNotEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (DoubleNotEqualFunc e1 e2) = DoubleNotEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (IntNotEqualFunc e1 e2) = IntNotEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (UintNotEqualFunc e1 e2) = UintNotEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (StringNotEqualFunc e1 e2) = StringNotEqualFunc (simplifyExpr e1) (simplifyExpr e2) -simplifyExpr (BytesNotEqualFunc e1 e2) = BytesNotEqualFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- uintExpr creates a constant uint expression from a input value. +uintExpr :: Word -> Expr Word +uintExpr i = Expr { + desc = Desc { + _name = "uint" + , _toStr = show i + , _hash = hashString (show i) + , _params = [] + , _hasVar = False + } + , eval = const $ return i +} -simplifyExpr (BytesTypeFunc e) = BytesTypeFunc (simplifyExpr e) -simplifyExpr (BoolTypeFunc e) = BoolTypeFunc (simplifyExpr e) -simplifyExpr (DoubleTypeFunc e) = DoubleTypeFunc (simplifyExpr e) -simplifyExpr (IntTypeFunc e) = IntTypeFunc (simplifyExpr e) -simplifyExpr (UintTypeFunc e) = UintTypeFunc (simplifyExpr e) -simplifyExpr (StringTypeFunc e) = StringTypeFunc (simplifyExpr e) +-- | +-- stringExpr creates a constant string expression from a input value. +stringExpr :: Text -> Expr Text +stringExpr s = Expr { + desc = Desc { + _name = "string" + , _toStr = show s + , _hash = hashString (unpack s) + , _params = [] + , _hasVar = False + } + , eval = const $ return s +} -simplifyExpr (RegexFunc e1 e2) = RegexFunc (simplifyExpr e1) (simplifyExpr e2) +-- | +-- bytesExpr creates a constant bytes expression from a input value. +bytesExpr :: ByteString -> Expr ByteString +bytesExpr b = Expr { + desc = Desc { + _name = "bytes" + , _toStr = "[]byte{" ++ show b ++ "}" + , _hash = hashString (show b) + , _params = [] + , _hasVar = False + } + , eval = const $ return b +} -simplifyExpr (DoubleListElemFunc es e) = DoubleListElemFunc (map simplifyExpr es) (simplifyExpr e) +-- | +-- trimBool tries to reduce an expression to a single constant expression, +-- if it does not contain a variable. +trimBool :: Expr Bool -> Expr Bool +trimBool e = if hasVar e + then e + else case eval e noLabel of + (Left _) -> e + (Right v) -> boolExpr v -simplifyExpr (IntListElemFunc es e) = IntListElemFunc (map simplifyExpr es) (simplifyExpr e) -simplifyExpr (BytesListLengthFunc es) = Const (length es) -simplifyExpr (BoolListLengthFunc es) = Const (length es) -simplifyExpr (BytesLengthFunc e) = case simplifyExpr e of - (Const b) -> Const (length b) - b -> BytesLengthFunc b -simplifyExpr (DoubleListLengthFunc es) = Const (length es) -simplifyExpr (IntListLengthFunc es) = Const (length es) -simplifyExpr (StringListLengthFunc es) = Const (length es) -simplifyExpr (UintListLengthFunc es) = Const (length es) -simplifyExpr (StringLengthFunc e) = case simplifyExpr e of - (Const b) -> Const (length b) - b -> StringLengthFunc b +-- | +-- trimInt tries to reduce an expression to a single constant expression, +-- if it does not contain a variable. +trimInt :: Expr Int -> Expr Int +trimInt e = if hasVar e + then e + else case eval e noLabel of + (Left _) -> e + (Right v) -> intExpr v -simplifyExpr (UintListElemFunc es e) = UintListElemFunc (map simplifyExpr es) (simplifyExpr e) +-- | +-- trimUint tries to reduce an expression to a single constant expression, +-- if it does not contain a variable. +trimUint :: Expr Word -> Expr Word +trimUint e = if hasVar e + then e + else case eval e noLabel of + (Left _) -> e + (Right v) -> uintExpr v -simplifyExpr (StringListElemFunc es e) = StringListElemFunc (map simplifyExpr es) (simplifyExpr e) -simplifyExpr (StringToLowerFunc e) = case simplifyExpr e of - (Const s) -> Const $ map toLower s - s -> s -simplifyExpr (StringToUpperFunc e) = case simplifyExpr e of - (Const s) -> Const $ map toUpper s - s -> s +-- | +-- trimString tries to reduce an expression to a single constant expression, +-- if it does not contain a variable. +trimString :: Expr Text -> Expr Text +trimString e = if hasVar e + then e + else case eval e noLabel of + (Left _) -> e + (Right v) -> stringExpr v -simplifyExpr (BytesListElemFunc es e) = BytesListElemFunc (map simplifyExpr es) (simplifyExpr e) +-- | +-- trimDouble tries to reduce an expression to a single constant expression, +-- if it does not contain a variable. +trimDouble :: Expr Double -> Expr Double +trimDouble e = if hasVar e + then e + else case eval e noLabel of + (Left _) -> e + (Right v) -> doubleExpr v -simplifyExpr e = e +-- | +-- trimBytes tries to reduce an expression to a single constant expression, +-- if it does not contain a variable. +trimBytes :: Expr ByteString -> Expr ByteString +trimBytes e = if hasVar e + then e + else case eval e noLabel of + (Left _) -> e + (Right v) -> bytesExpr v -simplifyOrFunc :: Expr Bool -> Expr Bool -> Expr Bool -simplifyOrFunc true@(Const True) _ = true -simplifyOrFunc _ true@(Const True) = true -simplifyOrFunc (Const False) v = v -simplifyOrFunc v (Const False) = v -simplifyOrFunc v1 v2 - | v1 == v2 = v1 - | v1 == simplifyNotFunc v2 = Const True - | simplifyNotFunc v1 == v2 = Const True - | otherwise = OrFunc v1 v2 +-- | +-- boolsExpr sequences a list of expressions that each return a bool, +-- to a single expression that returns a list of bools. +boolsExpr :: [Expr Bool] -> Expr [Bool] +boolsExpr = seqExprs "[]bool" -simplifyAndFunc :: Expr Bool -> Expr Bool -> Expr Bool -simplifyAndFunc (Const True) v = v -simplifyAndFunc v (Const True) = v -simplifyAndFunc false@(Const False) _ = false -simplifyAndFunc _ false@(Const False) = false +-- | +-- intsExpr sequences a list of expressions that each return an int, +-- to a single expression that returns a list of ints. +intsExpr :: [Expr Int] -> Expr [Int] +intsExpr = seqExprs "[]int" -simplifyAndFunc v1@(StringEqualFunc s1 s2) (StringEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, StringVariable, Const c2, StringVariable) -> if c1 == c2 then v1 else Const False - (Const c1, StringVariable, StringVariable, Const c2) -> if c1 == c2 then v1 else Const False - (StringVariable, Const c1, Const c2, StringVariable) -> if c1 == c2 then v1 else Const False - (StringVariable, Const c1, StringVariable, Const c2) -> if c1 == c2 then v1 else Const False -simplifyAndFunc v1@(StringEqualFunc s1 s2) (StringNotEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, StringVariable, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False - (Const c1, StringVariable, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False - (StringVariable, Const c1, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False - (StringVariable, Const c1, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False -simplifyAndFunc v1@(StringNotEqualFunc s1 s2) (StringEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, StringVariable, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False - (Const c1, StringVariable, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False - (StringVariable, Const c1, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False - (StringVariable, Const c1, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False +-- | +-- stringsExpr sequences a list of expressions that each return a string, +-- to a single expression that returns a list of strings. +stringsExpr :: [Expr Text] -> Expr [Text] +stringsExpr = seqExprs "[]string" -simplifyAndFunc v1@(IntEqualFunc s1 s2) (IntEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, IntVariable, Const c2, IntVariable) -> if c1 == c2 then v1 else Const False - (Const c1, IntVariable, IntVariable, Const c2) -> if c1 == c2 then v1 else Const False - (IntVariable, Const c1, Const c2, IntVariable) -> if c1 == c2 then v1 else Const False - (IntVariable, Const c1, IntVariable, Const c2) -> if c1 == c2 then v1 else Const False -simplifyAndFunc v1@(IntEqualFunc s1 s2) (IntNotEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, IntVariable, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False - (Const c1, IntVariable, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False - (IntVariable, Const c1, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False - (IntVariable, Const c1, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False -simplifyAndFunc v1@(IntNotEqualFunc s1 s2) (IntEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, IntVariable, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False - (Const c1, IntVariable, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False - (IntVariable, Const c1, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False - (IntVariable, Const c1, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False +-- | +-- doublesExpr sequences a list of expressions that each return a double, +-- to a single expression that returns a list of doubles. +doublesExpr :: [Expr Double] -> Expr [Double] +doublesExpr = seqExprs "[]double" -simplifyAndFunc v1@(UintEqualFunc s1 s2) (UintEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, UintVariable, Const c2, UintVariable) -> if c1 == c2 then v1 else Const False - (Const c1, UintVariable, UintVariable, Const c2) -> if c1 == c2 then v1 else Const False - (UintVariable, Const c1, Const c2, UintVariable) -> if c1 == c2 then v1 else Const False - (UintVariable, Const c1, UintVariable, Const c2) -> if c1 == c2 then v1 else Const False -simplifyAndFunc v1@(UintEqualFunc s1 s2) (UintNotEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, UintVariable, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False - (Const c1, UintVariable, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False - (UintVariable, Const c1, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False - (UintVariable, Const c1, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False -simplifyAndFunc v1@(UintNotEqualFunc s1 s2) (UintEqualFunc s1' s2') = - case (s1, s2, s1', s2') of - (Const c1, UintVariable, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False - (Const c1, UintVariable, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False - (UintVariable, Const c1, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False - (UintVariable, Const c1, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False +-- | +-- listOfBytesExpr sequences a list of expressions that each return bytes, +-- to a single expression that returns a list of bytes. +listOfBytesExpr :: [Expr ByteString] -> Expr [ByteString] +listOfBytesExpr = seqExprs "[][]byte" -simplifyAndFunc v1 v2 - | v1 == v2 = v1 - | v1 == simplifyNotFunc v2 = Const False - | simplifyNotFunc v1 == v2 = Const False - | otherwise = AndFunc v1 v2 +-- | +-- uintsExpr sequences a list of expressions that each return a uint, +-- to a single expression that returns a list of uints. +uintsExpr :: [Expr Word] -> Expr [Word] +uintsExpr = seqExprs "[]uint" -simplifyNotFunc :: Expr Bool -> Expr Bool -simplifyNotFunc (NotFunc v) = v -simplifyNotFunc (Const True) = Const False -simplifyNotFunc (Const False) = Const True -simplifyNotFunc (AndFunc e1 e2) = simplifyOrFunc (simplifyNotFunc e1) (simplifyNotFunc e2) -simplifyNotFunc (OrFunc e1 e2) = simplifyAndFunc (simplifyNotFunc e1) (simplifyNotFunc e2) -simplifyNotFunc (BoolEqualFunc e1 e2) = BoolNotEqualFunc e1 e2 -simplifyNotFunc (DoubleEqualFunc e1 e2) = DoubleNotEqualFunc e1 e2 -simplifyNotFunc (IntEqualFunc e1 e2) = IntNotEqualFunc e1 e2 -simplifyNotFunc (UintEqualFunc e1 e2) = UintNotEqualFunc e1 e2 -simplifyNotFunc (StringEqualFunc e1 e2) = StringNotEqualFunc e1 e2 -simplifyNotFunc (BytesEqualFunc e1 e2) = BytesNotEqualFunc e1 e2 -simplifyNotFunc (BoolNotEqualFunc e1 e2) = BoolEqualFunc e1 e2 -simplifyNotFunc (DoubleNotEqualFunc e1 e2) = DoubleEqualFunc e1 e2 -simplifyNotFunc (IntNotEqualFunc e1 e2) = IntEqualFunc e1 e2 -simplifyNotFunc (UintNotEqualFunc e1 e2) = UintEqualFunc e1 e2 -simplifyNotFunc (StringNotEqualFunc e1 e2) = StringEqualFunc e1 e2 -simplifyNotFunc (BytesNotEqualFunc e1 e2) = BytesEqualFunc e1 e2 -simplifyNotFunc v = NotFunc v +seqExprs :: String -> [Expr a] -> Expr [a] +seqExprs n es = Expr { + desc = mkDesc n (map desc es) + , eval = \v -> mapM (`eval` v) es +} diff --git a/src/Exprs.hs b/src/Exprs.hs new file mode 100644 --- /dev/null +++ b/src/Exprs.hs @@ -0,0 +1,86 @@ +-- | +-- This module contains the standard library of expressions, used by the Relapse parser. + +module Exprs ( + mkBuiltIn + , mkExpr + , MkFunc + , stdOnly +) where + +import Expr +import Exprs.Compare +import Exprs.Contains +import Exprs.Elem +import Exprs.Length +import Exprs.Logic +import Exprs.Strings +import Exprs.Type +import Exprs.Var + +-- | +-- MkFunc is used by the parser to create a function from a name and arguments. +type MkFunc = String -> [AnyExpr] -> Either String AnyExpr + +-- | +-- mkExpr is a grouping of all the standard library functions as one MkFunc. +mkExpr :: String -> [AnyExpr] -> Either String AnyExpr +mkExpr "eq" es = mkEqExpr es +mkExpr "ne" es = mkNeExpr es +mkExpr "ge" es = mkGeExpr es +mkExpr "gt" es = mkGtExpr es +mkExpr "le" es = mkLeExpr es +mkExpr "lt" es = mkLtExpr es +mkExpr "contains" es = mkContainsExpr es +mkExpr "elem" es = mkElemExpr es +mkExpr "length" es = mkLengthExpr es +mkExpr "not" es = mkNotExpr es +mkExpr "and" es = mkAndExpr es +mkExpr "or" es = mkOrExpr es +mkExpr "hasPrefix" es = mkHasPrefixExpr es +mkExpr "hasSuffix" es = mkHasSuffixExpr es +mkExpr "regex" es = mkRegexExpr es +mkExpr "toLower" es = mkToLowerExpr es +mkExpr "toUpper" es = mkToUpperExpr es +mkExpr "type" es = mkTypeExpr es +mkExpr n _ = Left $ "unknown function: " ++ n + +-- | +-- stdOnly contains no functions, which means that when it is combined +-- (in Relapse parser) with mkExpr the parser will have access to only the standard library. +stdOnly :: String -> [AnyExpr] -> Either String AnyExpr +stdOnly n _ = Left $ "unknown function: " ++ n + +-- | +-- mkBuiltIn parsers a builtin function to a relapse expression. +mkBuiltIn :: String -> AnyExpr -> Either String AnyExpr +mkBuiltIn symbol constExpr = funcName symbol >>= (\n -> + if n == "type" then + mkExpr n [constExpr] + else if n == "regex" then + mkExpr n [constExpr, constToVar constExpr] + else + mkExpr n [constToVar constExpr, constExpr] + ) + +funcName :: String -> Either String String +funcName "==" = return "eq" +funcName "!=" = return "ne" +funcName "<" = return "lt" +funcName ">" = return "gt" +funcName "<=" = return "le" +funcName ">=" = return "ge" +funcName "~=" = return "regex" +funcName "*=" = return "contains" +funcName "^=" = return "hasPrefix" +funcName "$=" = return "hasSuffix" +funcName "::" = return "type" +funcName n = fail $ "unexpected funcName: <" ++ n ++ ">" + +constToVar :: AnyExpr -> AnyExpr +constToVar (AnyExpr _ (BoolFunc _)) = mkBoolExpr varBoolExpr +constToVar (AnyExpr _ (IntFunc _)) = mkIntExpr varIntExpr +constToVar (AnyExpr _ (UintFunc _)) = mkUintExpr varUintExpr +constToVar (AnyExpr _ (DoubleFunc _)) = mkDoubleExpr varDoubleExpr +constToVar (AnyExpr _ (StringFunc _)) = mkStringExpr varStringExpr +constToVar (AnyExpr _ (BytesFunc _)) = mkBytesExpr varBytesExpr diff --git a/src/Exprs/Compare.hs b/src/Exprs/Compare.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Compare.hs @@ -0,0 +1,191 @@ +-- | +-- This module contains the Relapse compare expressions: +-- equal, not equal, greater than, greater than or equal, less than and less than or equal. +module Exprs.Compare ( + mkEqExpr, eqExpr + , mkNeExpr, neExpr + , mkGeExpr, geExpr + , mkLeExpr, leExpr + , mkGtExpr, gtExpr + , mkLtExpr, ltExpr +) where + +import Expr + +-- | +-- mkEqExpr dynamically creates an eq (equal) expression, if the two input types are the same. +mkEqExpr :: [AnyExpr] -> Either String AnyExpr +mkEqExpr es = do { + (e1, e2) <- assertArgs2 "eq" es; + case e1 of + (AnyExpr _ (BoolFunc _)) -> mkEqExpr' <$> assertBool e1 <*> assertBool e2 + (AnyExpr _ (IntFunc _)) -> mkEqExpr' <$> assertInt e1 <*> assertInt e2 + (AnyExpr _ (UintFunc _)) -> mkEqExpr' <$> assertUint e1 <*> assertUint e2 + (AnyExpr _ (DoubleFunc _)) -> mkEqExpr' <$> assertDouble e1 <*> assertDouble e2 + (AnyExpr _ (StringFunc _)) -> mkEqExpr' <$> assertString e1 <*> assertString e2 + (AnyExpr _ (BytesFunc _)) -> mkEqExpr' <$> assertBytes e1 <*> assertBytes e2 +} + +mkEqExpr' :: (Eq a) => Expr a -> Expr a -> AnyExpr +mkEqExpr' e f = mkBoolExpr $ eqExpr e f + +-- | +-- eqExpr creates an eq (equal) expression that returns true if the two evaluated input expressions are equal +-- and both don't evaluate to an error. +eqExpr :: (Eq a) => Expr a -> Expr a -> Expr Bool +eqExpr a b = trimBool Expr { + desc = mkDesc "eq" [desc a, desc b] + , eval = \v -> eq (eval a v) (eval b v) +} + +eq :: (Eq a) => Either String a -> Either String a -> Either String Bool +eq (Right v1) (Right v2) = return $ v1 == v2 +eq (Left _) _ = return False +eq _ (Left _) = return False + +-- | +-- mkNeExpr dynamically creates a ne (not equal) expression, if the two input types are the same. +mkNeExpr :: [AnyExpr] -> Either String AnyExpr +mkNeExpr es = do { + (e1, e2) <- assertArgs2 "ne" es; + case e1 of + (AnyExpr _ (BoolFunc _)) -> mkNeExpr' <$> assertBool e1 <*> assertBool e2 + (AnyExpr _ (IntFunc _)) -> mkNeExpr' <$> assertInt e1 <*> assertInt e2 + (AnyExpr _ (UintFunc _)) -> mkNeExpr' <$> assertUint e1 <*> assertUint e2 + (AnyExpr _ (DoubleFunc _)) -> mkNeExpr' <$> assertDouble e1 <*> assertDouble e2 + (AnyExpr _ (StringFunc _)) -> mkNeExpr' <$> assertString e1 <*> assertString e2 + (AnyExpr _ (BytesFunc _)) -> mkNeExpr' <$> assertBytes e1 <*> assertBytes e2 +} + +mkNeExpr' :: (Eq a) => Expr a -> Expr a -> AnyExpr +mkNeExpr' e f = mkBoolExpr $ neExpr e f + +-- | +-- neExpr creates a ne (not equal) expression that returns true if the two evaluated input expressions are not equal +-- and both don't evaluate to an error. +neExpr :: (Eq a) => Expr a -> Expr a -> Expr Bool +neExpr a b = trimBool Expr { + desc = mkDesc "ne" [desc a, desc b] + , eval = \v -> ne (eval a v) (eval b v) +} + +ne :: (Eq a) => Either String a -> Either String a -> Either String Bool +ne (Right v1) (Right v2) = return $ v1 /= v2 +ne (Left _) _ = return False +ne _ (Left _) = return False + +-- | +-- mkGeExpr dynamically creates a ge (greater than or equal) expression, if the two input types are the same. +mkGeExpr :: [AnyExpr] -> Either String AnyExpr +mkGeExpr es = do { + (e1, e2) <- assertArgs2 "ge" es; + case e1 of + (AnyExpr _ (IntFunc _)) -> mkGeExpr' <$> assertInt e1 <*> assertInt e2 + (AnyExpr _ (UintFunc _)) -> mkGeExpr' <$> assertUint e1 <*> assertUint e2 + (AnyExpr _ (DoubleFunc _)) -> mkGeExpr' <$> assertDouble e1 <*> assertDouble e2 + (AnyExpr _ (BytesFunc _)) -> mkGeExpr' <$> assertBytes e1 <*> assertBytes e2 +} + +mkGeExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr +mkGeExpr' e f = mkBoolExpr $ geExpr e f + +-- | +-- geExpr creates a ge (greater than or equal) expression that returns true if the first evaluated expression is greater than or equal to the second +-- and both don't evaluate to an error. +geExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool +geExpr a b = trimBool Expr { + desc = mkDesc "ge" [desc a, desc b] + , eval = \v -> ge (eval a v) (eval b v) +} + +ge :: (Ord a) => Either String a -> Either String a -> Either String Bool +ge (Right v1) (Right v2) = return $ v1 >= v2 +ge (Left _) _ = return False +ge _ (Left _) = return False + +-- | +-- mkGtExpr dynamically creates a gt (greater than) expression, if the two input types are the same. +mkGtExpr :: [AnyExpr] -> Either String AnyExpr +mkGtExpr es = do { + (e1, e2) <- assertArgs2 "gt" es; + case e1 of + (AnyExpr _ (IntFunc _)) -> mkGtExpr' <$> assertInt e1 <*> assertInt e2 + (AnyExpr _ (UintFunc _)) -> mkGtExpr' <$> assertUint e1 <*> assertUint e2 + (AnyExpr _ (DoubleFunc _)) -> mkGtExpr' <$> assertDouble e1 <*> assertDouble e2 + (AnyExpr _ (BytesFunc _)) -> mkGtExpr' <$> assertBytes e1 <*> assertBytes e2 +} + +mkGtExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr +mkGtExpr' e f = mkBoolExpr $ gtExpr e f + +-- | +-- gtExpr creates a gt (greater than) expression that returns true if the first evaluated expression is greater than the second +-- and both don't evaluate to an error. +gtExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool +gtExpr a b = trimBool Expr { + desc = mkDesc "gt" [desc a, desc b] + , eval = \v -> gt (eval a v) (eval b v) +} + +gt :: (Ord a) => Either String a -> Either String a -> Either String Bool +gt (Right v1) (Right v2) = return $ v1 > v2 +gt (Left _) _ = return False +gt _ (Left _) = return False + +-- | +-- mkLeExpr dynamically creates a le (less than or equal) expression, if the two input types are the same. +mkLeExpr :: [AnyExpr] -> Either String AnyExpr +mkLeExpr es = do { + (e1, e2) <- assertArgs2 "le" es; + case e1 of + (AnyExpr _ (IntFunc _)) -> mkLeExpr' <$> assertInt e1 <*> assertInt e2 + (AnyExpr _ (UintFunc _)) -> mkLeExpr' <$> assertUint e1 <*> assertUint e2 + (AnyExpr _ (DoubleFunc _)) -> mkLeExpr' <$> assertDouble e1 <*> assertDouble e2 + (AnyExpr _ (BytesFunc _)) -> mkLeExpr' <$> assertBytes e1 <*> assertBytes e2 +} + +mkLeExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr +mkLeExpr' e f = mkBoolExpr $ leExpr e f + +-- | +-- leExpr creates a le (less than or equal) expression that returns true if the first evaluated expression is less than or equal to the second +-- and both don't evaluate to an error. +leExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool +leExpr a b = trimBool Expr { + desc = mkDesc "le" [desc a, desc b] + , eval = \v -> le (eval a v) (eval b v) +} + +le :: (Ord a) => Either String a -> Either String a -> Either String Bool +le (Right v1) (Right v2) = return $ v1 <= v2 +le (Left _) _ = return False +le _ (Left _) = return False + +-- | +-- mkLtExpr dynamically creates a lt (less than) expression, if the two input types are the same. +mkLtExpr :: [AnyExpr] -> Either String AnyExpr +mkLtExpr es = do { + (e1, e2) <- assertArgs2 "lt" es; + case e1 of + (AnyExpr _ (IntFunc _)) -> mkLtExpr' <$> assertInt e1 <*> assertInt e2 + (AnyExpr _ (UintFunc _)) -> mkLtExpr' <$> assertUint e1 <*> assertUint e2 + (AnyExpr _ (DoubleFunc _)) -> mkLtExpr' <$> assertDouble e1 <*> assertDouble e2 + (AnyExpr _ (BytesFunc _)) -> mkLtExpr' <$> assertBytes e1 <*> assertBytes e2 +} + +mkLtExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr +mkLtExpr' e f = mkBoolExpr $ ltExpr e f + +-- | +-- ltExpr creates a lt (less than) expression that returns true if the first evaluated expression is less than the second +-- and both don't evaluate to an error. +ltExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool +ltExpr a b = trimBool Expr { + desc = mkDesc "lt" [desc a, desc b] + , eval = \v -> lt (eval a v) (eval b v) +} + +lt :: (Ord a) => Either String a -> Either String a -> Either String Bool +lt (Right v1) (Right v2) = return $ v1 < v2 +lt (Left _) _ = return False +lt _ (Left _) = return False diff --git a/src/Exprs/Contains.hs b/src/Exprs/Contains.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Contains.hs @@ -0,0 +1,48 @@ +-- | +-- This module contains the Relapse contains expressions. +module Exprs.Contains ( + mkContainsExpr + , containsStringExpr + , containsExpr +) where + +import qualified Data.Text as Text + +import Expr + +-- | +-- mkContainsExpr dynamically creates a contains expression, if the two input types are: +-- +-- * String and String where the second string is the possible substring. +-- * A List of :Strings, Ints or Uints paired with a String, Int or Uint respectively. +mkContainsExpr :: [AnyExpr] -> Either String AnyExpr +mkContainsExpr es = do { + (e1, e2) <- assertArgs2 "contains" es; + case e2 of + (AnyExpr _ (StringFunc _)) -> mkContainsStringExpr' <$> assertString e1 <*> assertString e2 + (AnyExpr _ (StringsFunc _)) -> mkContainsExpr' <$> assertString e1 <*> assertStrings e2 + (AnyExpr _ (IntsFunc _)) -> mkContainsExpr' <$> assertInt e1 <*> assertInts e2 + (AnyExpr _ (UintsFunc _)) -> mkContainsExpr' <$> assertUint e1 <*> assertUints e2 +} + +mkContainsStringExpr' :: Expr Text.Text -> Expr Text.Text -> AnyExpr +mkContainsStringExpr' e f = mkBoolExpr $ containsStringExpr e f + +-- | +-- containsStringExpr creates a contains expression that returns true if the second string is a substring of the first. +containsStringExpr :: Expr Text.Text -> Expr Text.Text -> Expr Bool +containsStringExpr s sub = trimBool Expr { + desc = mkDesc "contains" [desc s, desc sub] + , eval = \v -> Text.isInfixOf <$> eval sub v <*> eval s v +} + +mkContainsExpr' :: (Eq a) => Expr a -> Expr [a] -> AnyExpr +mkContainsExpr' e f = mkBoolExpr $ containsExpr e f + +-- | +-- containsExpr creates a contains expression that returns true if the first argument is an element in the second list argument. +containsExpr :: (Eq a) => Expr a -> Expr [a] -> Expr Bool +containsExpr e es = trimBool Expr { + desc = mkDesc "contains" [desc e, desc es] + , eval = \v -> elem <$> eval e v <*> eval es v +} diff --git a/src/Exprs/Elem.hs b/src/Exprs/Elem.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Elem.hs @@ -0,0 +1,35 @@ +-- | +-- This module contains the Relapse elem expression. +module Exprs.Elem ( + mkElemExpr + , elemExpr +) where + +import Expr + +-- | +-- mkElemExpr dynamically creates an elem expression, if the first argument is a list and the second an int index. +mkElemExpr :: [AnyExpr] -> Either String AnyExpr +mkElemExpr es = do { + (e1, e2) <- assertArgs2 "elem" es; + case e1 of + (AnyExpr _ (BoolsFunc _)) -> mkElemExpr' mkBoolExpr <$> assertBools e1 <*> assertInt e2 + (AnyExpr _ (IntsFunc _)) -> mkElemExpr' mkIntExpr <$> assertInts e1 <*> assertInt e2 + (AnyExpr _ (UintsFunc _)) -> mkElemExpr' mkUintExpr <$> assertUints e1 <*> assertInt e2 + (AnyExpr _ (DoublesFunc _)) -> mkElemExpr' mkDoubleExpr <$> assertDoubles e1 <*> assertInt e2 + (AnyExpr _ (StringsFunc _)) -> mkElemExpr' mkStringExpr <$> assertStrings e1 <*> assertInt e2 + (AnyExpr _ (ListOfBytesFunc _)) -> mkElemExpr' mkBytesExpr <$> assertListOfBytes e1 <*> assertInt e2 +} + +mkElemExpr' :: (Expr a -> AnyExpr) -> Expr [a] -> Expr Int -> AnyExpr +mkElemExpr' mk list index = mk $ elemExpr list index + +-- | +-- elemExpr creates an expression that returns an element from the list at the specified index. +-- Trimming this function would cause it to become non generic. +-- It is not necessary to trim each function, since it is just an optimization. +elemExpr :: Expr [a] -> Expr Int -> Expr a +elemExpr a b = Expr { + desc = mkDesc "elem" [desc a, desc b] + , eval = \v -> (!!) <$> eval a v <*> eval b v +} diff --git a/src/Exprs/Length.hs b/src/Exprs/Length.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Length.hs @@ -0,0 +1,54 @@ +-- | +-- This module contains the Relapse length expressions. +module Exprs.Length ( + mkLengthExpr + , lengthListExpr + , lengthStringExpr + , lengthBytesExpr +) where + +import qualified Data.Text as Text +import qualified Data.ByteString as ByteString + +import Expr + +-- | +-- mkLengthExpr dynamically creates a length expression, if the single argument is a list, string or bytes. +mkLengthExpr :: [AnyExpr] -> Either String AnyExpr +mkLengthExpr es = do { + e <- assertArgs1 "length" es; + case e of + (AnyExpr _ (BoolsFunc _)) -> mkIntExpr . lengthListExpr <$> assertBools e; + (AnyExpr _ (IntsFunc _)) -> mkIntExpr . lengthListExpr <$> assertInts e; + (AnyExpr _ (UintsFunc _)) -> mkIntExpr . lengthListExpr <$> assertUints e; + (AnyExpr _ (DoublesFunc _)) -> mkIntExpr . lengthListExpr <$> assertDoubles e; + (AnyExpr _ (StringsFunc _)) -> mkIntExpr . lengthListExpr <$> assertStrings e; + (AnyExpr _ (ListOfBytesFunc _)) -> mkIntExpr . lengthListExpr <$> assertListOfBytes e; + (AnyExpr _ (StringFunc _)) -> mkIntExpr . lengthStringExpr <$> assertString e; + (AnyExpr _ (BytesFunc _)) -> mkIntExpr . lengthBytesExpr <$> assertBytes e; +} + +-- | +-- lengthListExpr creates a length expression, that returns the length of a list. +lengthListExpr :: Expr [a] -> Expr Int +lengthListExpr e = trimInt Expr { + desc = mkDesc "length" [desc e] + , eval = \v -> length <$> eval e v +} + +-- | +-- lengthStringExpr creates a length expression, that returns the length of a string. +lengthStringExpr :: Expr Text.Text -> Expr Int +lengthStringExpr e = trimInt Expr { + desc = mkDesc "length" [desc e] + , eval = \v -> Text.length <$> eval e v +} + +-- | +-- lengthBytesExpr creates a length expression, that returns the length of bytes. +lengthBytesExpr :: Expr ByteString.ByteString -> Expr Int +lengthBytesExpr e = trimInt Expr { + desc = mkDesc "length" [desc e] + , eval = \v -> ByteString.length <$> eval e v +} + diff --git a/src/Exprs/Logic.hs b/src/Exprs/Logic.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Logic.hs @@ -0,0 +1,128 @@ +-- | +-- This module contains the Relapse logic expressions: not, and, or. +module Exprs.Logic ( + mkNotExpr, notExpr + , mkAndExpr, andExpr + , mkOrExpr, orExpr +) where + +import Expr +import Exprs.Var + +-- | +-- mkNotExpr dynamically creates a not expression, if the single argument is a bool expression. +mkNotExpr :: [AnyExpr] -> Either String AnyExpr +mkNotExpr es = do { + e <- assertArgs1 "not" es; + b <- assertBool e; + return $ mkBoolExpr (notExpr b); +} + +-- | +-- notExpr creates a not expression, that returns true is the argument expression returns an error or false. +notExpr :: Expr Bool -> Expr Bool +notExpr e = trimBool Expr { + desc = notDesc (desc e) + , eval = \v -> case eval e v of + (Left _) -> return True + (Right b) -> return $ not b +} + +-- notDesc superficially pushes not operators down to normalize functions. +-- Normalizing functions increases the chances of finding equal expressions and being able to simplify patterns. +notDesc :: Desc -> Desc +notDesc d + | _name d == "not" = + let child0 = head $ _params d + in mkDesc (_name child0) (_params child0) + | _name d == "and" = + let [left, right] = _params d + in mkDesc "or" [mkDesc "not" [left], mkDesc "not" [right]] + | _name d == "or" = + let [left, right] = _params d + in mkDesc "and" [mkDesc "not" [left], mkDesc "not" [right]] + | _name d == "ne" = mkDesc "eq" $ _params d + | _name d == "eq" = mkDesc "ne" $ _params d + | otherwise = mkDesc "not" [d] + +-- | +-- mkAndExpr dynamically creates an and expression, if the two arguments are both bool expressions. +mkAndExpr :: [AnyExpr] -> Either String AnyExpr +mkAndExpr es = do { + (e1, e2) <- assertArgs2 "and" es; + b1 <- assertBool e1; + b2 <- assertBool e2; + return $ mkBoolExpr $ andExpr b1 b2; +} + +-- | +-- andExpr creates an and expression that returns true if both arguments are true. +andExpr :: Expr Bool -> Expr Bool -> Expr Bool +andExpr a b = case (evalConst a, evalConst b) of + (Just False, _) -> boolExpr False + (_, Just False) -> boolExpr False + (Just True, _) -> b + (_, Just True) -> a + _ -> andExpr' a b + +-- andExpr' creates an `and` expression, but assumes that both expressions have a var. +andExpr' :: Expr Bool -> Expr Bool -> Expr Bool +andExpr' a b + | a == b = a + | name a == "not" && head (params a) == desc b = boolExpr False + | name b == "not" && head (params b) == desc a = boolExpr False + | name a == "eq" && name b == "eq" = case (varAndConst a, varAndConst b) of + (Just ca, Just cb) -> if ca == cb then a else boolExpr False + _ -> defaultAnd a b + | name a == "eq" && name b == "ne" = case (varAndConst a, varAndConst b) of + (Just ca, Just cb) -> if ca == cb then boolExpr False else a + _ -> defaultAnd a b + | name a == "ne" && name b == "eq" = case (varAndConst a, varAndConst b) of + (Just ca, Just cb) -> if ca == cb then boolExpr False else b + _ -> defaultAnd a b + | otherwise = defaultAnd a b + +defaultAnd :: Expr Bool -> Expr Bool -> Expr Bool +defaultAnd a b = Expr { + desc = mkDesc "and" [desc a, desc b] + , eval = \v -> (&&) <$> eval a v <*> eval b v +} + +varAndConst :: Expr Bool -> Maybe Desc +varAndConst e = let ps = params e + in if length ps /= 2 then Nothing + else let [a,b] = ps in + if isVar a && isConst b then Just b + else if isVar b && isConst a then Just a + else Nothing + +-- | +-- mkOrExpr dynamically creates an or expression, if the two arguments are both bool expressions. +mkOrExpr :: [AnyExpr] -> Either String AnyExpr +mkOrExpr es = do { + (e1, e2) <- assertArgs2 "or" es; + b1 <- assertBool e1; + b2 <- assertBool e2; + return $ mkBoolExpr $ orExpr b1 b2; +} + +-- | +-- orExpr creates an or expression that returns true if either argument is true. +orExpr :: Expr Bool -> Expr Bool -> Expr Bool +orExpr a b = case (evalConst a, evalConst b) of + (Just True, _) -> boolExpr True + (_, Just True) -> boolExpr True + (Just False, _) -> b + (_, Just False) -> a + _ -> orExpr' a b + +-- orExpr' creates an `or` expression, but assumes that both expressions have a var. +orExpr' :: Expr Bool -> Expr Bool -> Expr Bool +orExpr' a b + | a == b = a + | name a == "not" && head (params a) == desc b = boolExpr True + | name b == "not" && head (params b) == desc a = boolExpr True + | otherwise = Expr { + desc = mkDesc "or" [desc a, desc b] + , eval = \v -> (||) <$> eval a v <*> eval b v + } diff --git a/src/Exprs/Strings.hs b/src/Exprs/Strings.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Strings.hs @@ -0,0 +1,107 @@ +-- | +-- This module contains the Relapse string expressions. + +module Exprs.Strings ( + mkHasPrefixExpr, hasPrefixExpr + , mkHasSuffixExpr, hasSuffixExpr + , mkRegexExpr, regexExpr + , mkToLowerExpr, toLowerExpr + , mkToUpperExpr, toUpperExpr +) where + +import Text.Regex.TDFA ((=~)) +import Data.Text (Text, isPrefixOf, isSuffixOf, toLower, toUpper, unpack) + +import Expr + +-- | +-- mkHasPrefixExpr dynamically creates a hasPrefix expression. +mkHasPrefixExpr :: [AnyExpr] -> Either String AnyExpr +mkHasPrefixExpr es = do { + (e1, e2) <- assertArgs2 "hasPrefix" es; + s1 <- assertString e1; + s2 <- assertString e2; + return $ mkBoolExpr $ hasPrefixExpr s1 s2; +} + +-- | +-- hasPrefixExpr creates a hasPrefix expression that returns true if the second is a prefix of the first. +hasPrefixExpr :: Expr Text -> Expr Text -> Expr Bool +hasPrefixExpr e1 e2 = trimBool Expr { + desc = mkDesc "hasPrefix" [desc e1, desc e2] + , eval = \v -> isPrefixOf <$> eval e2 v <*> eval e1 v +} + +-- | +-- mkHasSuffixExpr dynamically creates a hasSuffix expression. +mkHasSuffixExpr :: [AnyExpr] -> Either String AnyExpr +mkHasSuffixExpr es = do { + (e1, e2) <- assertArgs2 "hasSuffix" es; + s1 <- assertString e1; + s2 <- assertString e2; + return $ mkBoolExpr $ hasSuffixExpr s1 s2; +} + +-- | +-- hasSuffixExpr creates a hasSuffix expression that returns true if the second is a suffix of the first. +hasSuffixExpr :: Expr Text -> Expr Text -> Expr Bool +hasSuffixExpr e1 e2 = trimBool Expr { + desc = mkDesc "hasSuffix" [desc e1, desc e2] + , eval = \v -> isSuffixOf <$> eval e2 v <*> eval e1 v +} + +-- | +-- mkRegexExpr dynamically creates a regex expression. +mkRegexExpr :: [AnyExpr] -> Either String AnyExpr +mkRegexExpr es = do { + (e1, e2) <- assertArgs2 "regex" es; + e <- assertString e1; + s <- assertString e2; + return $ mkBoolExpr $ regexExpr e s; +} + +-- | +-- regexExpr creates a regex expression that returns true if the first expression matches the second string. +regexExpr :: Expr Text -> Expr Text -> Expr Bool +regexExpr e s = trimBool Expr { + desc = mkDesc "regex" [desc e, desc s] + , eval = \v -> do { + s1 <- eval s v; + e1 <- eval e v; + return $ (=~) (unpack s1) (unpack e1); + } +} + +-- | +-- mkToLowerExpr dynamically creates a toLower expression. +mkToLowerExpr :: [AnyExpr] -> Either String AnyExpr +mkToLowerExpr es = do { + e <- assertArgs1 "toLower" es; + s <- assertString e; + return $ mkStringExpr $ toLowerExpr s; +} + +-- | +-- toLowerExpr creates a toLower expression that converts the input string to a lowercase string. +toLowerExpr :: Expr Text -> Expr Text +toLowerExpr e = trimString Expr { + desc = mkDesc "toLower" [desc e] + , eval = \v -> toLower <$> eval e v +} + +-- | +-- mkToUpperExpr dynamically creates a toUpper expression. +mkToUpperExpr :: [AnyExpr] -> Either String AnyExpr +mkToUpperExpr es = do { + e <- assertArgs1 "toUpper" es; + s <- assertString e; + return $ mkStringExpr $ toUpperExpr s; +} + +-- | +-- toUpperExpr creates a toUpper expression that converts the input string to an uppercase string. +toUpperExpr :: Expr Text -> Expr Text +toUpperExpr e = trimString Expr { + desc = mkDesc "toUpper" [desc e] + , eval = \v -> toUpper <$> eval e v +} diff --git a/src/Exprs/Type.hs b/src/Exprs/Type.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Type.hs @@ -0,0 +1,36 @@ +-- | +-- This module contains the Relapse type expression. + +module Exprs.Type ( + mkTypeExpr + , typeExpr +) where + +import Expr + +-- | +-- mkTypeExpr is used by the parser to create a type expression for the specific input type. +mkTypeExpr :: [AnyExpr] -> Either String AnyExpr +mkTypeExpr es = do { + e <- assertArgs1 "type" es; + case e of + (AnyExpr _ (BoolFunc _)) -> mkBoolExpr . typeExpr <$> assertBool e; + (AnyExpr _ (IntFunc _)) -> mkBoolExpr . typeExpr <$> assertInt e; + (AnyExpr _ (UintFunc _)) -> mkBoolExpr . typeExpr <$> assertUint e; + (AnyExpr _ (DoubleFunc _)) -> mkBoolExpr . typeExpr <$> assertDouble e; + (AnyExpr _ (StringFunc _)) -> mkBoolExpr . typeExpr <$> assertString e; + (AnyExpr _ (BytesFunc _)) -> mkBoolExpr . typeExpr <$> assertBytes e; +} + +-- | +-- typeExpr creates an expression that returns true if the containing expression does not return an error. +-- For example: `(typeExpr varBoolExpr)` will ony return true is the field value is a bool. +typeExpr :: Expr a -> Expr Bool +typeExpr e = Expr { + desc = mkDesc "type" [desc e] + , eval = \v -> case eval e v of + (Left _) -> return False + (Right _) -> return True +} + + diff --git a/src/Exprs/Var.hs b/src/Exprs/Var.hs new file mode 100644 --- /dev/null +++ b/src/Exprs/Var.hs @@ -0,0 +1,126 @@ +-- | +-- This module contains all expressions for Relapse variables. + +module Exprs.Var ( + varBoolExpr + , varIntExpr + , varUintExpr + , varDoubleExpr + , varStringExpr + , varBytesExpr + , isVar +) where + +import Data.Text (Text) +import Data.ByteString (ByteString) + +import qualified Parsers +import Expr + +-- | +-- isVar returns whether an expression is one of the six variable expressions. +isVar :: Desc -> Bool +isVar d = null (_params d) && case _name d of + "$bool" -> True + "$int" -> True + "$uint" -> True + "$double" -> True + "$string" -> True + "$[]byte" -> True + _ -> False + +-- | +-- varBoolExpr creates a bool variable expression. +varBoolExpr :: Expr Bool +varBoolExpr = Expr { + desc = Desc { + _name = "$bool" + , _toStr = "$bool" + , _hash = hashWithName "$bool" [] + , _params = [] + , _hasVar = True + } + , eval = \l -> case l of + (Parsers.Bool b) -> Right b + _ -> Left "not a bool" +} + +-- | +-- varIntExpr creates an int variable expression. +varIntExpr :: Expr Int +varIntExpr = Expr { + desc = Desc { + _name = "$int" + , _toStr = "$int" + , _hash = hashWithName "$int" [] + , _params = [] + , _hasVar = True + } + , eval = \l -> case l of + (Parsers.Int i) -> Right i + _ -> Left "not an int" +} + +-- | +-- varUintExpr creates a uint variable expression. +varUintExpr :: Expr Word +varUintExpr = Expr { + desc = Desc { + _name = "$uint" + , _toStr = "$uint" + , _hash = hashWithName "$uint" [] + , _params = [] + , _hasVar = True + } + , eval = \l -> case l of + (Parsers.Uint u) -> Right u + _ -> Left "not a uint" +} + +-- | +-- varDoubleExpr creates a double variable expression. +varDoubleExpr :: Expr Double +varDoubleExpr = Expr { + desc = Desc { + _name = "$double" + , _toStr = "$double" + , _hash = hashWithName "$double" [] + , _params = [] + , _hasVar = True + } + , eval = \l -> case l of + (Parsers.Double d) -> Right d + _ -> Left "not a double" +} + +-- | +-- varStringExpr creates a string variable expression. +varStringExpr :: Expr Text +varStringExpr = Expr { + desc = Desc { + _name = "$string" + , _toStr = "$string" + , _hash = hashWithName "$string" [] + , _params = [] + , _hasVar = True + } + , eval = \l -> case l of + (Parsers.String s) -> Right s + _ -> Left "not a string" +} + +-- | +-- varBytesExpr creates a bytes variable expression. +varBytesExpr :: Expr ByteString +varBytesExpr = Expr { + desc = Desc { + _name = "$[]byte" + , _toStr = "$[]byte" + , _hash = hashWithName "$[]byte" [] + , _params = [] + , _hasVar = True + } + , eval = \l -> case l of + (Parsers.Bytes b) -> Right b + _ -> Left "not bytes" +} diff --git a/src/IfExprs.hs b/src/IfExprs.hs --- a/src/IfExprs.hs +++ b/src/IfExprs.hs @@ -9,19 +9,23 @@ ZippedIfExprs, zipIfExprs, evalZippedIfExprs ) where -import Control.Monad.Except (Except) - -import Patterns +import Smart import Expr +import Exprs.Logic import Simplify import Zip import Parsers +-- | +-- IfExpr contains a condition and a return pattern for each of the two cases. newtype IfExpr = IfExpr (Expr Bool, Pattern, Pattern) +-- | +-- newIfExpr creates an IfExpr. newIfExpr :: Expr Bool -> Pattern -> Pattern -> IfExpr newIfExpr c t e = IfExpr (c, t, e) +-- | IfExprs is a tree of if expressions, which contains a list of resulting patterns on each of its leaves. data IfExprs = Cond { cond :: Expr Bool @@ -30,38 +34,34 @@ } | Ret [Pattern] -compileIfExprs :: Refs -> [IfExpr] -> IfExprs -compileIfExprs _ [] = Ret [] -compileIfExprs refs (e:es) = let (IfExpr ifExpr) = simplifyIf refs e - in addIfExpr ifExpr (compileIfExprs refs es) +-- | compileIfExprs compiles a list of if expressions in an IfExprs tree, for efficient evaluation. +compileIfExprs :: [IfExpr] -> IfExprs +compileIfExprs [] = Ret [] +compileIfExprs (IfExpr ifExpr:es) = addIfExpr ifExpr (compileIfExprs es) -evalIfExprs :: IfExprs -> Label -> Except ValueErr [Pattern] +-- | valIfExprs evaluates a tree of if expressions and returns the resulting patterns or an error. +evalIfExprs :: IfExprs -> Label -> Either String [Pattern] evalIfExprs (Ret ps) _ = return ps evalIfExprs (Cond c t e) l = do { b <- eval c l; if b then evalIfExprs t l else evalIfExprs e l } -simplifyIf :: Refs -> IfExpr -> IfExpr -simplifyIf refs (IfExpr (c, t, e)) = - let scond = simplifyBoolExpr c - sthn = simplify refs t - sels = simplify refs e - in if sthn == sels then IfExpr (Const True, sthn, sels) else IfExpr (scond, sthn, sels) - addIfExpr :: (Expr Bool, Pattern, Pattern) -> IfExprs -> IfExprs addIfExpr (c, t, e) (Ret ps) = Cond c (Ret (t:ps)) (Ret (e:ps)) addIfExpr (c, t, e) (Cond cs ts es) | c == cs = Cond cs (addRet t ts) (addRet e es) - | Const False == simplifyBoolExpr (AndFunc c cs) = Cond cs (addRet e ts) (addIfExpr (c, t, e) es) - | Const False == simplifyBoolExpr (AndFunc (NotFunc c) cs) = Cond cs (addIfExpr (c, t, e) ts) (addRet t es) + | boolExpr False == andExpr c cs = Cond cs (addRet e ts) (addIfExpr (c, t, e) es) + | boolExpr False == andExpr (notExpr c) cs = Cond cs (addIfExpr (c, t, e) ts) (addRet t es) | otherwise = Cond cs (addIfExpr (c, t, e) ts) (addIfExpr (c, t, e) es) addRet :: Pattern -> IfExprs -> IfExprs addRet p (Ret ps) = Ret (p:ps) addRet p (Cond c t e) = Cond c (addRet p t) (addRet p e) +-- | +-- ZippedIfExprs is a tree of if expressions, but with a zipped pattern list and a zipper on each of the leaves. data ZippedIfExprs = ZippedCond { zcond :: Expr Bool @@ -70,11 +70,13 @@ } | ZippedRet [Pattern] Zipper +-- | zipIfExprs compresses an if expression tree's leaves. zipIfExprs :: IfExprs -> ZippedIfExprs zipIfExprs (Cond c t e) = ZippedCond c (zipIfExprs t) (zipIfExprs e) zipIfExprs (Ret ps) = let (zps, zs) = zippy ps in ZippedRet zps zs -evalZippedIfExprs :: ZippedIfExprs -> Label -> Except ValueErr ([Pattern], Zipper) +-- | evalZippedIfExprs evaulates a ZippedIfExprs tree and returns the zipped pattern list and zipper from the resulting leaf. +evalZippedIfExprs :: ZippedIfExprs -> Label -> Either String ([Pattern], Zipper) evalZippedIfExprs (ZippedRet ps zs) _ = return (ps, zs) evalZippedIfExprs (ZippedCond c t e) v = do { b <- eval c v; diff --git a/src/Json.hs b/src/Json.hs --- a/src/Json.hs +++ b/src/Json.hs @@ -8,6 +8,8 @@ ) where import Text.JSON (decode, Result(..), JSValue(..), fromJSString, fromJSObject) +import Data.Ratio (denominator) +import Data.Text (pack) import qualified Data.Tree as DataTree import Parsers @@ -30,17 +32,19 @@ uValue :: JSValue -> [JsonTree] uValue JSNull = [] uValue (JSBool b) = [DataTree.Node (Bool b) []] -uValue (JSRational _ r) = [DataTree.Node (Number r) []] -uValue (JSString s) = [DataTree.Node (String (fromJSString s)) []] +uValue (JSRational _ r) = if denominator r /= 1 + then [DataTree.Node (Double (fromRational r :: Double)) []] + else [DataTree.Node (Int $ truncate r) []] +uValue (JSString s) = [DataTree.Node (String $ pack $ fromJSString s) []] uValue (JSArray vs) = uArray 0 vs uValue (JSObject o) = uObject $ fromJSObject o uArray :: Int -> [JSValue] -> [JsonTree] uArray _ [] = [] -uArray index (v:vs) = DataTree.Node (Number (toRational index)) (uValue v):uArray (index+1) vs +uArray index (v:vs) = DataTree.Node (Int index) (uValue v):uArray (index+1) vs uObject :: [(String, JSValue)] -> [JsonTree] uObject = map uKeyValue uKeyValue :: (String, JSValue) -> JsonTree -uKeyValue (name, value) = DataTree.Node (String name) (uValue value) +uKeyValue (name, value) = DataTree.Node (String $ pack name) (uValue value) diff --git a/src/MemDerive.hs b/src/MemDerive.hs --- a/src/MemDerive.hs +++ b/src/MemDerive.hs @@ -8,16 +8,15 @@ -- This module provides memoization of the nullable, calls and returns functions. module MemDerive ( - derive, Mem, newMem, nullable, validate + derive, Mem, newMem, validate ) where import qualified Data.Map.Strict as M import Control.Monad.State (State, runState, lift, state) -import Control.Monad.Except (ExceptT, runExceptT, Except, throwError, runExcept) +import Control.Monad.Trans.Either (EitherT, runEitherT, left, hoistEither) import qualified Derive -import qualified Patterns -import Patterns (Refs, Pattern) +import Smart (Grammar, Pattern, lookupRef, nullable, lookupMain) import IfExprs import Expr import Zip @@ -29,69 +28,60 @@ | otherwise = let res = f k in (res, M.insert k res m) -type Nullable = M.Map Pattern Bool type Calls = M.Map [Pattern] IfExprs type Returns = M.Map ([Pattern], [Bool]) [Pattern] -- | -- Mem is the object used to store memoized results of the nullable, calls and returns functions. -newtype Mem = Mem (Nullable, Calls, Returns) +newtype Mem = Mem (Calls, Returns) -- | -- newMem creates a object used for memoization by the validate function. -- Each grammar should create its own memoize object. newMem :: Mem -newMem = Mem (M.empty, M.empty, M.empty) - --- | --- nullable returns whether a pattern is nullable and memoizes the results. -nullable :: Refs -> Pattern -> State Mem Bool -nullable refs k = state $ \(Mem (n, c, r)) -> let (v', n') = mem (Patterns.nullable refs) k n; - in (v', Mem (n', c, r)) +newMem = Mem (M.empty, M.empty) -calls :: Refs -> [Pattern] -> State Mem IfExprs -calls refs k = state $ \(Mem (n, c, r)) -> let (v', c') = mem (Derive.calls refs) k c; - in (v', Mem (n, c', r)) +calls :: Grammar -> [Pattern] -> State Mem IfExprs +calls g k = state $ \(Mem (c, r)) -> let (v', c') = mem (Derive.calls g) k c; + in (v', Mem (c', r)) -returns :: Refs -> ([Pattern], [Bool]) -> State Mem [Pattern] -returns refs k = state $ \(Mem (n, c, r)) -> let (v', r') = mem (Derive.returns refs) k r; - in (v', Mem (n, c, r')) +returns :: Grammar -> ([Pattern], [Bool]) -> State Mem [Pattern] +returns g k = state $ \(Mem (c, r)) -> let (v', r') = mem (Derive.returns g) k r; + in (v', Mem (c, r')) -mderive :: Tree t => Refs -> [Pattern] -> [t] -> ExceptT ValueErr (State Mem) [Pattern] +mderive :: Tree t => Grammar -> [Pattern] -> [t] -> EitherT String (State Mem) [Pattern] mderive _ ps [] = return ps -mderive refs ps (tree:ts) = do { - ifs <- lift $ calls refs ps; - childps <- case runExcept $ evalIfExprs ifs (getLabel tree) of - (Left l) -> throwError l - (Right r) -> return r - ; +mderive g ps (tree:ts) = do { + ifs <- lift $ calls g ps; + childps <- hoistEither $ evalIfExprs ifs (getLabel tree); (zchildps, zipper) <- return $ zippy childps; - childres <- mderive refs zchildps (getChildren tree); - nulls <- lift $ mapM (nullable refs) childres; - let unzipns = unzipby zipper nulls + childres <- mderive g zchildps (getChildren tree); + let + nulls = map nullable childres + unzipns = unzipby zipper nulls ; - rs <- lift $ returns refs (ps, unzipns); - mderive refs rs ts + rs <- lift $ returns g (ps, unzipns); + mderive g rs ts } -- | -- derive is the classic derivative implementation for trees. -derive :: Tree t => Refs -> [t] -> Except String Pattern -derive refs ts = - let start = [Patterns.lookupRef refs "main"] - (res, _) = runState (runExceptT $ mderive refs start ts) newMem +derive :: Tree t => Grammar -> [t] -> Either String Pattern +derive g ts = + let start = [lookupMain g] + (res, _) = runState (runEitherT $ mderive g start ts) newMem in case res of - (Left l) -> throwError $ show l + (Left l) -> Left l (Right [r]) -> return r - (Right rs) -> throwError $ "not a single pattern: " ++ show rs + (Right rs) -> Left $ "not a single pattern: " ++ show rs -- | -- validate is the uses the derivative implementation for trees and -- return whether tree is valid, given the input grammar and start pattern. -validate :: Tree t => Refs -> Pattern -> [t] -> (State Mem) Bool -validate refs start tree = do { - rs <- runExceptT (mderive refs [start] tree); - case rs of - (Right [r]) -> nullable refs r - _ -> return False - } +validate :: Tree t => Grammar -> Pattern -> [t] -> (State Mem) Bool +validate g start tree = do { + rs <- runEitherT (mderive g [start] tree); + return $ case rs of + (Right [r]) -> nullable r + _ -> False +} diff --git a/src/ParsePatterns.hs b/src/ParsePatterns.hs deleted file mode 100644 --- a/src/ParsePatterns.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-#LANGUAGE GADTs #-} - --- | --- This is an internal relapse module. --- --- It contains relapse grammar parsing helper functions and --- --- it also contains a parser for the JSON serialized relapse AST. - -module ParsePatterns ( - ParsedExpr(..), newBuiltIn, newFunction, fromJson -) where - -import Text.JSON (decode, Result(..), JSValue(..), fromJSString, fromJSObject) - -import Patterns -import Expr - -data ParsedExpr - = BoolExpr (Expr Bool) - | DoubleExpr (Expr Double) - | IntExpr (Expr Int) - | UintExpr (Expr Uint) - | StringExpr (Expr String) - | BytesExpr (Expr Bytes) - | BoolListExpr [Expr Bool] - | DoubleListExpr [Expr Double] - | IntListExpr [Expr Int] - | UintListExpr [Expr Uint] - | StringListExpr [Expr String] - | BytesListExpr [Expr Bytes] - deriving Show - --- | --- fromJson parses the relapse AST that has been serialized to JSON. -fromJson :: String -> Either String Refs -fromJson s = unmarshal $ decode s - -unmarshal :: Result JSValue -> Either String Refs -unmarshal (Error err) = fail err -unmarshal (Ok (JSObject o)) = uRefs $ fromJSObject o -unmarshal (Ok j) = fail $ "unexpected jsvalue = " ++ show j - -uRefs :: [(String, JSValue)] -> Either String Refs -uRefs [] = return emptyRef -uRefs (("TopPattern", JSObject pattern):pairs) = do { - p <- uPattern (fromJSObject pattern); - rs <- uRefs pairs; - return $ newRef "main" p `union` rs -} -uRefs (("PatternDecls", JSArray patternDecls):pairs) = do { - p <- uPatternDecls patternDecls; - rs <- uRefs pairs; - return $ p `union` rs -} -uRefs (_:pairs) = uRefs pairs - -uPatternDecls :: [JSValue] -> Either String Refs -uPatternDecls [] = return emptyRef -uPatternDecls (JSObject o:patternDecls) = do { - left <- uPatternDecl (fromJSObject o); - right <- uPatternDecls patternDecls; - return $ left `union` right -} - -uPatternDecl :: [(String, JSValue)] -> Either String Refs -uPatternDecl kvs = do { - name <- getString kvs "Name"; - p <- getObject kvs "Pattern"; - pattern <- uPattern p; - return $ newRef name pattern -} - -uPattern :: [(String, JSValue)] -> Either String Pattern -uPattern [("Empty", _)] = return Empty -uPattern [("TreeNode", JSObject o)] = uTreeNode (fromJSObject o) -uPattern [("LeafNode", JSObject o)] = uLeafNode (fromJSObject o) -uPattern [("Concat", JSObject o)] = uLeftRight Concat (fromJSObject o) -uPattern [("Or", JSObject o)] = uLeftRight Or (fromJSObject o) -uPattern [("And", JSObject o)] = uLeftRight And (fromJSObject o) -uPattern [("ZeroOrMore", JSObject o)] = uZeroOrMore (fromJSObject o) -uPattern [("Reference", JSObject o)] = uReference (fromJSObject o) -uPattern [("Not", JSObject o)] = uNot (fromJSObject o) -uPattern [("ZAny", JSObject o)] = return ZAny -uPattern [("Contains", JSObject o)] = uContains (fromJSObject o) -uPattern [("Optional", JSObject o)] = uOptional (fromJSObject o) -uPattern [("Interleave", JSObject o)] = uLeftRight Interleave (fromJSObject o) - -uTreeNode :: [(String, JSValue)] -> Either String Pattern -uTreeNode kvs = do { - name <- getObject kvs "Name"; - nameExpr <- uNameExpr name; - p <- getObject kvs "Pattern"; - pattern <- uPattern p; - return $ Node nameExpr pattern -} - -uLeafNode :: [(String, JSValue)] -> Either String Pattern -uLeafNode kvs = flip Node Empty <$> (getObject kvs "Expr" >>= uBoolExpr) - -uReference :: [(String, JSValue)] -> Either String Pattern -uReference kvs = Reference <$> getString kvs "Name" - -uLeftRight :: (Pattern -> Pattern -> Pattern) -> [(String, JSValue)] -> Either String Pattern -uLeftRight combine kvs = do { - left <- getObject kvs "LeftPattern"; - leftPattern <- uPattern left; - right <- getObject kvs "RightPattern"; - rightPattern <- uPattern right; - return $ combine leftPattern rightPattern -} - -uZeroOrMore :: [(String, JSValue)] -> Either String Pattern -uZeroOrMore kvs = ZeroOrMore <$> (getObject kvs "Pattern" >>= uPattern) - -uNot :: [(String, JSValue)] -> Either String Pattern -uNot kvs = Not <$> (getObject kvs "Pattern" >>= uPattern) - -uContains :: [(String, JSValue)] -> Either String Pattern -uContains kvs = Contains <$> (getObject kvs "Pattern" >>= uPattern) - -uOptional :: [(String, JSValue)] -> Either String Pattern -uOptional kvs = Optional <$> (getObject kvs "Pattern" >>= uPattern) - -uNameExpr :: [(String, JSValue)] -> Either String (Expr Bool) -uNameExpr [("Name", JSObject o)] = return $ uName (fromJSObject o) -uNameExpr [("AnyName", JSObject o)] = return $ Const True -uNameExpr [("AnyNameEither", JSObject o)] = uNameEither (fromJSObject o) -uNameExpr [("NameChoice", JSObject o)] = uNameChoice (fromJSObject o) - -uName :: [(String, JSValue)] -> Expr Bool -uName kvs = uName' $ head $ filter (\(k,v) -> (k /= "Before")) kvs - -uName' :: (String, JSValue) -> Expr Bool -uName' ("DoubleValue", JSRational _ num) = DoubleEqualFunc (Const (fromRational num)) DoubleVariable -uName' ("IntValue", JSRational _ num) = IntEqualFunc (Const $ truncate num) IntVariable -uName' ("UintValue", JSRational _ num) = UintEqualFunc (Const $ truncate num) UintVariable -uName' ("BoolValue", JSBool b) = BoolEqualFunc (Const b) BoolVariable -uName' ("StringValue", JSString s) = StringEqualFunc (Const $ fromJSString s) StringVariable -uName' ("BytesValue", JSString s) = BytesEqualFunc (Const $ fromJSString s) BytesVariable - -uNameEither :: [(String, JSValue)] -> Either String (Expr Bool) -uNameEither kvs = NotFunc <$> (getObject kvs "Either" >>= uNameExpr) - -uNameChoice :: [(String, JSValue)] -> Either String (Expr Bool) -uNameChoice kvs = do { - left <- getObject kvs "Left"; - leftName <- uNameExpr left; - right <- getObject kvs "Right"; - rightName <- uNameExpr right; - return $ OrFunc leftName rightName -} - -uBoolExpr :: [(String, JSValue)] -> Either String (Expr Bool) -uBoolExpr kvs = uExprs kvs >>= (\e -> - case e of - (BoolExpr v) -> return v - _ -> fail $ "not a BoolExpr, but a " ++ show e - ) - -uDoubleExpr :: [(String, JSValue)] -> Either String (Expr Double) -uDoubleExpr kvs = uExprs kvs >>= (\e -> - case e of - (DoubleExpr v) -> return v - _ -> fail $ "not a DoubleExpr, but a " ++ show e - ) - -uIntExpr :: [(String, JSValue)] -> Either String (Expr Int) -uIntExpr kvs = uExprs kvs >>= (\e -> - case e of - (IntExpr v) -> return v - _ -> fail $ "not a IntExpr, but a " ++ show e - ) - -uUintExpr :: [(String, JSValue)] -> Either String (Expr Uint) -uUintExpr kvs = uExprs kvs >>= (\e -> - case e of - (UintExpr v) -> return v - _ -> fail $ "not a UintExpr, but a " ++ show e - ) - -uStringExpr :: [(String, JSValue)] -> Either String (Expr String) -uStringExpr kvs = uExprs kvs >>= (\e -> - case e of - (StringExpr v) -> return v - _ -> fail $ "not a StringExpr, but a " ++ show e - ) - -uBytesExpr :: [(String, JSValue)] -> Either String (Expr Bytes) -uBytesExpr kvs = uExprs kvs >>= (\e -> - case e of - (BytesExpr v) -> return v - _ -> fail $ "not a BytesExpr, but a " ++ show e - ) - -uExprs :: [(String, JSValue)] -> Either String ParsedExpr -uExprs kvs = uExpr $ head $ filter (\(k,v) -> k /= "RightArrow" && k /= "Comma") kvs - -uExpr :: (String, JSValue) -> Either String ParsedExpr -uExpr ("Terminal", JSObject o) = return $ uTerminals $ fromJSObject o -uExpr ("List", JSObject o) = uList $ fromJSObject o -uExpr ("Function", JSObject o) = uFunction $ fromJSObject o -uExpr ("BuiltIn", JSObject o) = uBuiltIn $ fromJSObject o - -uTerminals :: [(String, JSValue)] -> ParsedExpr -uTerminals kvs = uTerminal $ head $ filter (\(k,v) -> k /= "Before" && k /= "Literal") kvs - -uTerminal :: (String, JSValue) -> ParsedExpr -uTerminal ("DoubleValue", JSRational _ n) = DoubleExpr (Const (fromRational n)) -uTerminal ("IntValue", JSRational _ n) = IntExpr (Const $ truncate n) -uTerminal ("UintValue", JSRational _ n) = UintExpr (Const $ truncate n) -uTerminal ("BoolValue", JSBool b) = BoolExpr (Const b) -uTerminal ("StringValue", JSString s) = StringExpr (Const $ fromJSString s) -uTerminal ("BytesValue", JSString s) = BytesExpr (Const $ fromJSString s) -- TODO bytes -uTerminal ("Variable", JSObject o) = uVariable $ fromJSObject o - -uVariable :: [(String, JSValue)] -> ParsedExpr -uVariable [("Type", JSRational _ 101)] = DoubleExpr DoubleVariable -uVariable [("Type", JSRational _ 103)] = IntExpr IntVariable -uVariable [("Type", JSRational _ 104)] = UintExpr UintVariable -uVariable [("Type", JSRational _ 108)] = BoolExpr BoolVariable -uVariable [("Type", JSRational _ 109)] = StringExpr StringVariable -uVariable [("Type", JSRational _ 112)] = BytesExpr BytesVariable - -uList :: [(String, JSValue)] -> Either String ParsedExpr -uList kvs = do { - arr <- getArrayOfObjects kvs "Elems"; - typ <- getInt kvs "Type"; - case typ of - 101 -> DoubleListExpr <$> mapM uDoubleExpr arr - 103 -> IntListExpr <$> mapM uIntExpr arr - 104 -> UintListExpr <$> mapM uUintExpr arr - 108 -> BoolListExpr <$> mapM uBoolExpr arr - 109 -> StringListExpr <$> mapM uStringExpr arr - 112 -> BytesListExpr <$> mapM uBytesExpr arr - 201 -> DoubleListExpr <$> mapM uDoubleExpr arr - 203 -> IntListExpr <$> mapM uIntExpr arr - 204 -> UintListExpr <$> mapM uUintExpr arr - 208 -> BoolListExpr <$> mapM uBoolExpr arr - 209 -> StringListExpr <$> mapM uStringExpr arr - 212 -> BytesListExpr <$> mapM uBytesExpr arr -} - -uFunction :: [(String, JSValue)] -> Either String ParsedExpr -uFunction kvs = do { - name <- getString kvs "Name"; - arrayObjects <- getArrayOfObjects kvs "Params"; - exprs <- mapM uExprs arrayObjects; - newFunction name exprs -} - --- | --- newFunction parsers a relapse function to a relapse expression. -newFunction :: String -> [ParsedExpr] -> Either String ParsedExpr -newFunction "not" [BoolExpr b] = Right $ BoolExpr $ NotFunc b -newFunction "and" [BoolExpr b1, BoolExpr b2] = Right $ BoolExpr $ AndFunc b1 b2 -newFunction "or" [BoolExpr b1, BoolExpr b2] = Right $ BoolExpr $ OrFunc b1 b2 - -newFunction "contains" [IntExpr i,IntListExpr is] = Right $ BoolExpr $ IntListContainsFunc i is -newFunction "contains" [StringExpr s, StringListExpr ss] = Right $ BoolExpr $ StringListContainsFunc s ss -newFunction "contains" [UintExpr u, UintListExpr us] = Right $ BoolExpr $ UintListContainsFunc u us -newFunction "contains" [StringExpr s, StringExpr ss] = Right $ BoolExpr $ StringContainsFunc s ss - -newFunction "elem" [BytesListExpr es, IntExpr i] = Right $ BytesExpr $ BytesListElemFunc es i -newFunction "elem" [BoolListExpr es, IntExpr i] = Right $ BoolExpr $ BoolListElemFunc es i -newFunction "elem" [DoubleListExpr es, IntExpr i] = Right $ DoubleExpr $ DoubleListElemFunc es i -newFunction "elem" [IntListExpr es, IntExpr i] = Right $ IntExpr $ IntListElemFunc es i -newFunction "elem" [StringListExpr es, IntExpr i] = Right $ StringExpr $ StringListElemFunc es i -newFunction "elem" [UintListExpr es, IntExpr i] = Right $ UintExpr $ UintListElemFunc es i - -newFunction "eq" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesEqualFunc v1 v2 -newFunction "eq" [BoolExpr v1, BoolExpr v2] = Right $ BoolExpr $ BoolEqualFunc v1 v2 -newFunction "eq" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleEqualFunc v1 v2 -newFunction "eq" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntEqualFunc v1 v2 -newFunction "eq" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringEqualFunc v1 v2 -newFunction "eq" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintEqualFunc v1 v2 - -newFunction "eqFold" _ = Left "eqFold function is not supported" - -newFunction "ge" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesGreaterOrEqualFunc v1 v2 -newFunction "ge" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleGreaterOrEqualFunc v1 v2 -newFunction "ge" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntGreaterOrEqualFunc v1 v2 -newFunction "ge" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintGreaterOrEqualFunc v1 v2 - -newFunction "gt" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesGreaterThanFunc v1 v2 -newFunction "gt" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleGreaterThanFunc v1 v2 -newFunction "gt" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntGreaterThanFunc v1 v2 -newFunction "gt" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintGreaterThanFunc v1 v2 - -newFunction "hasPrefix" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringHasPrefixFunc v1 v2 -newFunction "hasSuffix" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringHasSuffixFunc v1 v2 - -newFunction "le" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesLessOrEqualFunc v1 v2 -newFunction "le" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleLessOrEqualFunc v1 v2 -newFunction "le" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntLessOrEqualFunc v1 v2 -newFunction "le" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintLessOrEqualFunc v1 v2 - -newFunction "length" [BytesListExpr vs] = Right $ IntExpr $ BytesListLengthFunc vs -newFunction "length" [BoolListExpr vs] = Right $ IntExpr $ BoolListLengthFunc vs -newFunction "length" [BytesExpr vs] = Right $ IntExpr $ BytesLengthFunc vs -newFunction "length" [DoubleListExpr vs] = Right $ IntExpr $ DoubleListLengthFunc vs -newFunction "length" [IntListExpr vs] = Right $ IntExpr $ IntListLengthFunc vs -newFunction "length" [StringListExpr vs] = Right $ IntExpr $ StringListLengthFunc vs -newFunction "length" [UintListExpr vs] = Right $ IntExpr $ UintListLengthFunc vs -newFunction "length" [StringExpr vs] = Right $ IntExpr $ StringLengthFunc vs - -newFunction "lt" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesLessThanFunc v1 v2 -newFunction "lt" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleLessThanFunc v1 v2 -newFunction "lt" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntLessThanFunc v1 v2 -newFunction "lt" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintLessThanFunc v1 v2 - -newFunction "ne" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesNotEqualFunc v1 v2 -newFunction "ne" [BoolExpr v1, BoolExpr v2] = Right $ BoolExpr $ BoolNotEqualFunc v1 v2 -newFunction "ne" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleNotEqualFunc v1 v2 -newFunction "ne" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntNotEqualFunc v1 v2 -newFunction "ne" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringNotEqualFunc v1 v2 -newFunction "ne" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintNotEqualFunc v1 v2 - -newFunction "now" _ = Left "now function is not supported" - -newFunction "print" _ = Left "print function is not supported" - -newFunction "range" _ = Left "range function is not supported" - -newFunction "toLower" [StringExpr s] = Right $ StringExpr $ StringToLowerFunc s -newFunction "toUpper" [StringExpr s] = Right $ StringExpr $ StringToUpperFunc s - -newFunction "type" [BytesExpr b] = Right $ BoolExpr $ BytesTypeFunc b -newFunction "type" [BoolExpr b] = Right $ BoolExpr $ BoolTypeFunc b -newFunction "type" [DoubleExpr b] = Right $ BoolExpr $ DoubleTypeFunc b -newFunction "type" [IntExpr b] = Right $ BoolExpr $ IntTypeFunc b -newFunction "type" [UintExpr b] = Right $ BoolExpr $ UintTypeFunc b -newFunction "type" [StringExpr b] = Right $ BoolExpr $ StringTypeFunc b - -newFunction "regex" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ RegexFunc v1 v2 - -newFunction s t = Left $ "unknown function: " ++ s ++ " for types: " ++ show t - -uBuiltIn :: [(String, JSValue)] -> Either String ParsedExpr -uBuiltIn kvs = do { - exprObject <- getObject kvs "Expr"; - symbolObject <- getObject kvs "Symbol"; - symbol <- getString symbolObject "Value"; - exprs <- uExprs exprObject; - newBuiltIn symbol exprs; -} - --- | --- newBuiltIn parsers a builtin function to a relapse expression. -newBuiltIn :: String -> ParsedExpr -> Either String ParsedExpr -newBuiltIn symbol constExpr = funcName symbol >>= (\name -> - if name == "type" then - newFunction name [constExpr] - else if name == "regex" then - newFunction name [constExpr, constToVar constExpr] - else - newFunction name [constToVar constExpr, constExpr] - ) - -constToVar :: ParsedExpr -> ParsedExpr -constToVar (BoolExpr Const{}) = BoolExpr BoolVariable -constToVar (DoubleExpr Const{}) = DoubleExpr DoubleVariable -constToVar (IntExpr Const{}) = IntExpr IntVariable -constToVar (UintExpr Const{}) = UintExpr UintVariable -constToVar (BytesExpr Const{}) = BytesExpr BytesVariable -constToVar (StringExpr Const{}) = StringExpr StringVariable - -funcName :: String -> Either String String -funcName "==" = return "eq" -funcName "!=" = return "ne" -funcName "<" = return "lt" -funcName ">" = return "gt" -funcName "<=" = return "le" -funcName ">=" = return "ge" -funcName "~=" = return "regex" -funcName "*=" = return "contains" -funcName "^=" = return "hasPrefix" -funcName "$=" = return "hasSuffix" -funcName "::" = return "type" -funcName name = fail $ "unexpected funcName: <" ++ name ++ ">" - --- JSON helper functions - -getField :: [(String, JSValue)] -> String -> Either String JSValue -getField pairs name = let filtered = filter (\(k,_) -> (k == name)) pairs - in case filtered of - [] -> fail $ "no field with name: " ++ name - vs -> return $ snd $ head vs - -getString :: [(String, JSValue)] -> String -> Either String String -getString pairs name = getField pairs name >>= (\v -> - case v of - (JSString s) -> return $ fromJSString s - _ -> fail $ name ++ " is not a JSString, but a " ++ show v - ) - -getInt :: [(String, JSValue)] -> String -> Either String Int -getInt pairs name = getField pairs name >>= (\v -> - case v of - (JSRational _ n) -> return $ truncate n - _ -> fail $ name ++ " is not a JSRational, but a " ++ show v - ) - -getArrayOfObjects :: [(String, JSValue)] -> String -> Either String [[(String, JSValue)]] -getArrayOfObjects pairs name = getField pairs name >>= (\v -> - case v of - (JSArray vs) -> mapM assertObject vs - _ -> fail $ name ++ " is not a JSArray, but a " ++ show v - ) - -assertObject :: JSValue -> Either String [(String, JSValue)] -assertObject (JSObject o) = return $ fromJSObject o -assertObject v = fail $ "not an JSObject, but a " ++ show v - -getObject :: [(String, JSValue)] -> String -> Either String [(String, JSValue)] -getObject pairs name = getField pairs name >>= (\v -> - case v of - (JSObject o) -> return $ fromJSObject o - _ -> fail $ name ++ " is not an JSObject, but a " ++ show v - ) diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -3,7 +3,7 @@ module Parser ( -- * Parse Grammar - parseGrammar + parseGrammar, parseGrammarWithUDFs -- * Internal functions -- | These functions are exposed for testing purposes. , grammar, pattern, nameExpr, expr, @@ -13,15 +13,28 @@ import Text.ParserCombinators.Parsec import Numeric (readDec, readOct, readHex, readFloat) import Data.Char (chr) +import qualified Data.Text as Text +import qualified Data.ByteString.Char8 as ByteString +import Control.Arrow (left) import Expr -import Patterns -import ParsePatterns +import Exprs +import Exprs.Logic +import Exprs.Var +import Ast -- | parseGrammar parses the Relapse Grammar. -parseGrammar :: String -> Either ParseError Refs -parseGrammar = parse (grammar <* eof) "" +parseGrammar :: String -> Either String Grammar +parseGrammar = parseGrammarWithUDFs stdOnly +-- | parseGrammarWithUDFs parses the Relapse Grammar with extra user defined functions. +parseGrammarWithUDFs :: MkFunc -> String -> Either String Grammar +parseGrammarWithUDFs extraUDFs str = + let mkFunc n es = case mkExpr n es of + (Left _) -> extraUDFs n es + (Right v) -> return v + in left show $ parse (grammar mkFunc <* eof) "" str + infixl 4 <++> (<++>) :: CharParser () String -> CharParser () String -> CharParser () String f <++> g = (++) <$> f <*> g @@ -30,6 +43,11 @@ (<::>) :: CharParser () Char -> CharParser () String -> CharParser () String f <::> g = (:) <$> f <*> g +check :: Either String a -> CharParser () a +check e = case e of + (Left err) -> fail err + (Right v) -> return v + empty :: CharParser () String empty = return "" @@ -48,6 +66,7 @@ _ws :: CharParser () () _ws = _comment <|> () <$ space +-- | For internal testing ws :: CharParser () () ws = () <$ many _ws @@ -83,14 +102,24 @@ <|> return 0 ) +-- | For internal testing intLit :: CharParser () Int intLit = string "int(" *> _signedIntLit <* char ')' <|> _signedIntLit "int_lit" -uintCastLit :: CharParser () Int -uintCastLit = string "uint(" *> _intLit <* char ')' +uintLit :: CharParser () Word +uintLit = do { + i <- intLit; + if i < 0 + then fail "negative uint" + else return $ fromIntegral i; +} +-- | For internal testing +uintCastLit :: CharParser () Word +uintCastLit = string "uint(" *> uintLit <* char ')' + _exponent :: CharParser () String _exponent = oneOf "eE" <::> ( oneOf "+-" <::> many1 digit @@ -110,9 +139,11 @@ <|> empty _read readFloat (i ++ e) +-- | For internal testing doubleCastLit :: CharParser () Double doubleCastLit = string "double(" *> ((*) <$> _optionalSign <*> _floatLit) <* char ')' +-- | For internal testing idLit :: CharParser () String idLit = (letter <|> char '_') <::> many (alphaNum <|> char '_') @@ -151,8 +182,9 @@ _rawString :: CharParser () String _rawString = between (char '`') (char '`') (many $ noneOf "`") -stringLit :: CharParser () String -stringLit = _rawString <|> _interpretedString +-- | For internal testing +stringLit :: CharParser () Text.Text +stringLit = Text.pack <$> (_rawString <|> _interpretedString) _hexByteUValue :: CharParser () Char _hexByteUValue = char 'x' *> do { @@ -180,25 +212,26 @@ _byteElem :: CharParser () Char _byteElem = _byteLit <|> between (char '\'') (char '\'') (_unicodeValue <|> _octalByteUValue <|> _hexByteUValue) -bytesCastLit :: CharParser () String -bytesCastLit = string "[]byte{" *> sepBy (ws *> _byteElem <* ws) (char ',') <* char '}' +-- | For internal testing +bytesCastLit :: CharParser () ByteString.ByteString +bytesCastLit = ByteString.pack <$> (string "[]byte{" *> sepBy (ws *> _byteElem <* ws) (char ',') <* char '}') -_literal :: CharParser () ParsedExpr -_literal = BoolExpr . Const <$> bool - <|> IntExpr . Const <$> intLit - <|> UintExpr . Const <$> uintCastLit - <|> DoubleExpr . Const <$> doubleCastLit - <|> StringExpr . Const <$> stringLit - <|> BytesExpr . Const <$> bytesCastLit +_literal :: CharParser () AnyExpr +_literal = mkBoolExpr . boolExpr <$> bool + <|> mkIntExpr . intExpr <$> intLit + <|> mkUintExpr . uintExpr <$> uintCastLit + <|> mkDoubleExpr . doubleExpr <$> doubleCastLit + <|> mkStringExpr . stringExpr <$> stringLit + <|> mkBytesExpr . bytesExpr <$> bytesCastLit -_terminal :: CharParser () ParsedExpr +_terminal :: CharParser () AnyExpr _terminal = (char '$' *> ( - BoolExpr BoolVariable <$ string "bool" - <|> IntExpr IntVariable <$ string "int" - <|> UintExpr UintVariable <$ string "uint" - <|> DoubleExpr DoubleVariable <$ string "double" - <|> StringExpr StringVariable <$ string "string" - <|> BytesExpr BytesVariable <$ string "[]byte" )) + mkBoolExpr varBoolExpr <$ string "bool" + <|> mkIntExpr varIntExpr <$ string "int" + <|> mkUintExpr varUintExpr <$ string "uint" + <|> mkDoubleExpr varDoubleExpr <$ string "double" + <|> mkStringExpr varStringExpr <$ string "string" + <|> mkBytesExpr varBytesExpr <$ string "[]byte" )) <|> _literal _builtinSymbol :: CharParser () String @@ -212,15 +245,11 @@ <|> string "$=" <|> string "::" -check :: Either String ParsedExpr -> CharParser () ParsedExpr -check (Right r) = return r -check (Left l) = fail l - -_builtin :: CharParser () ParsedExpr -_builtin = newBuiltIn <$> _builtinSymbol <*> (ws *> _expr) >>= check +_builtin :: MkFunc -> CharParser () AnyExpr +_builtin mkFunc = mkBuiltIn <$> _builtinSymbol <*> (ws *> _expr mkFunc) >>= check -_function :: CharParser () ParsedExpr -_function = newFunction <$> idLit <*> (char '(' *> sepBy (ws *> _expr <* ws) (char ',') <* char ')') >>= check +_function :: MkFunc -> CharParser () AnyExpr +_function mkFunc = mkFunc <$> idLit <*> (char '(' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char ')') >>= check _listType :: CharParser () String _listType = char '[' <::> char ']' <::> ( @@ -231,53 +260,36 @@ <|> string "string" <|> string "[]byte" ) -_mustBool :: ParsedExpr -> CharParser () (Expr Bool) -_mustBool (BoolExpr e) = return e -_mustBool e = fail $ "want BoolExpr, got: " ++ show e - -_mustInt :: ParsedExpr -> CharParser () (Expr Int) -_mustInt (IntExpr e) = return e -_mustInt e = fail $ "want IntExpr, got: " ++ show e - -_mustUint :: ParsedExpr -> CharParser () (Expr Uint) -_mustUint (UintExpr e) = return e -_mustUint e = fail $ "want UintExpr, got: " ++ show e - -_mustDouble :: ParsedExpr -> CharParser () (Expr Double) -_mustDouble (DoubleExpr e) = return e -_mustDouble e = fail $ "want DoubleExpr, got: " ++ show e - -_mustString :: ParsedExpr -> CharParser () (Expr String) -_mustString (StringExpr e) = return e -_mustString e = fail $ "want StringExpr, got: " ++ show e - -_mustBytes :: ParsedExpr -> CharParser () (Expr Bytes) -_mustBytes (BytesExpr e) = return e -_mustBytes e = fail $ "want BytesExpr, got: " ++ show e +_mustBool :: AnyExpr -> CharParser () (Expr Bool) +_mustBool = check . assertBool -newList :: String -> [ParsedExpr] -> CharParser () ParsedExpr -newList "[]bool" es = BoolListExpr <$> mapM _mustBool es -newList "[]int" es = IntListExpr <$> mapM _mustInt es -newList "[]uint" es = UintListExpr <$> mapM _mustUint es -newList "[]double" es = DoubleListExpr <$> mapM _mustDouble es -newList "[]string" es = StringListExpr <$> mapM _mustString es -newList "[][]byte" es = BytesListExpr <$> mapM _mustBytes es +newList :: String -> [AnyExpr] -> CharParser () AnyExpr +newList "[]bool" es = mkBoolsExpr . boolsExpr <$> mapM (check . assertBool) es +newList "[]int" es = mkIntsExpr . intsExpr <$> mapM (check . assertInt) es +newList "[]uint" es = mkUintsExpr . uintsExpr <$> mapM (check . assertUint) es +newList "[]double" es = mkDoublesExpr . doublesExpr <$> mapM (check . assertDouble) es +newList "[]string" es = mkStringsExpr . stringsExpr <$> mapM (check . assertString) es +newList "[][]byte" es = mkListOfBytesExpr . listOfBytesExpr <$> mapM (check . assertBytes) es -_list :: CharParser () ParsedExpr -_list = do { +_list :: MkFunc -> CharParser () AnyExpr +_list mkFunc = do { ltype <- _listType; - es <- ws *> char '{' *> sepBy (ws *> _expr <* ws) (char ',') <* char '}'; + es <- ws *> char '{' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char '}'; newList ltype es } -_expr :: CharParser () ParsedExpr -_expr = try _terminal <|> _list <|> _function +_expr :: MkFunc -> CharParser () AnyExpr +_expr mkFunc = try _terminal <|> _list mkFunc <|> _function mkFunc -expr :: CharParser () (Expr Bool) -expr = (try _terminal <|> _builtin <|> _function) >>= _mustBool +-- | For internal testing +expr :: MkFunc -> CharParser () (Expr Bool) +expr mkFunc = (try _terminal <|> _builtin mkFunc <|> _function mkFunc) >>= _mustBool -_name :: CharParser () (Expr Bool) -_name = (newBuiltIn "==" <$> (_literal <|> (StringExpr . Const <$> idLit))) >>= check >>= _mustBool +_nameString :: CharParser () (Expr Bool) +_nameString = (mkBuiltIn "==" <$> + (_literal <|> + (mkStringExpr . stringExpr . Text.pack <$> idLit))) + >>= check >>= _mustBool sepBy2 :: CharParser () a -> String -> CharParser () [a] sepBy2 p sep = do { @@ -289,25 +301,26 @@ } _nameChoice :: CharParser () (Expr Bool) -_nameChoice = foldl1 OrFunc <$> sepBy2 (ws *> nameExpr <* ws) "|" +_nameChoice = foldl1 orExpr <$> sepBy2 (ws *> nameExpr <* ws) "|" +-- | For internal testing nameExpr :: CharParser () (Expr Bool) -nameExpr = (Const True <$ char '_') - <|> (NotFunc <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')')) +nameExpr = (boolExpr True <$ char '_') + <|> (notExpr <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')')) <|> (char '(' *> ws *> _nameChoice <* ws <* char ')') - <|> _name + <|> _nameString -_concatPattern :: CharParser () Pattern -_concatPattern = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern <* ws) ",") <* optional (char ',' <* ws) <* char ']' +_concatPattern :: MkFunc -> CharParser () Pattern +_concatPattern mkFunc = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern mkFunc <* ws) ",") <* optional (char ',' <* ws) <* char ']' -_interleavePattern :: CharParser () Pattern -_interleavePattern = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern <* ws) ";") <* optional (char ';' <* ws) <* char '}' +_interleavePattern :: MkFunc -> CharParser () Pattern +_interleavePattern mkFunc = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern mkFunc <* ws) ";") <* optional (char ';' <* ws) <* char '}' -_parenPattern :: CharParser () Pattern -_parenPattern = do { +_parenPattern :: MkFunc -> CharParser () Pattern +_parenPattern mkFunc = do { char '('; ws; - first <- pattern; + first <- pattern mkFunc; ws; ( char ')' *> ws *> ( @@ -316,23 +329,23 @@ ) ) <|> ( ( - (first <$ char '|' >>= _orList) <|> - (first <$ char '&' >>= _andList) + (first <$ char '|' >>= _orList mkFunc) <|> + (first <$ char '&' >>= _andList mkFunc) ) <* char ')' ) } -_orList :: Pattern -> CharParser () Pattern -_orList p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern <* ws) (char '|') +_orList :: MkFunc -> Pattern -> CharParser () Pattern +_orList mkFunc p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern mkFunc <* ws) (char '|') -_andList :: Pattern -> CharParser () Pattern -_andList p = And p . foldl1 And <$> sepBy1 (ws *> pattern <* ws) (char '&') +_andList :: MkFunc -> Pattern -> CharParser () Pattern +_andList mkFunc p = And p . foldl1 And <$> sepBy1 (ws *> pattern mkFunc <* ws) (char '&') _refPattern :: CharParser () Pattern _refPattern = Reference <$> (char '@' *> ws *> idLit) -_notPattern :: CharParser () Pattern -_notPattern = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern <* ws <* char ')') +_notPattern :: MkFunc -> CharParser () Pattern +_notPattern mkFunc = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern mkFunc <* ws <* char ')') _emptyPattern :: CharParser () Pattern _emptyPattern = Empty <$ string "" @@ -340,34 +353,36 @@ _zanyPattern :: CharParser () Pattern _zanyPattern = ZAny <$ string "*" -_containsPattern :: CharParser () Pattern -_containsPattern = Contains <$> (char '.' *> pattern) +_containsPattern :: MkFunc -> CharParser () Pattern +_containsPattern mkFunc = Contains <$> (char '.' *> pattern mkFunc) -_treenodePattern :: CharParser () Pattern -_treenodePattern = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern) <|> _depthPattern ) ) +_treenodePattern :: MkFunc -> CharParser () Pattern +_treenodePattern mkFunc = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern mkFunc) <|> _depthPattern mkFunc) ) -_depthPattern :: CharParser () Pattern -_depthPattern = _concatPattern <|> _interleavePattern <|> _containsPattern - <|> flip Node Empty <$> ( (string "->" *> expr ) <|> (_builtin >>= _mustBool) ) +_depthPattern :: MkFunc -> CharParser () Pattern +_depthPattern mkFunc = _concatPattern mkFunc <|> _interleavePattern mkFunc<|> _containsPattern mkFunc + <|> flip Node Empty <$> ( (string "->" *> expr mkFunc) <|> (_builtin mkFunc>>= _mustBool) ) -newContains :: CharParser () ParsedExpr -> CharParser () Pattern -newContains e = flip Node Empty <$> ((newBuiltIn "*=" <$> e) >>= check >>= _mustBool) +newContains :: CharParser () AnyExpr -> CharParser () Pattern +newContains e = flip Node Empty <$> ((mkBuiltIn "*=" <$> e) >>= check >>= _mustBool) -pattern :: CharParser () Pattern -pattern = char '*' *> ( - (char '=' *> (newContains (ws *> _expr))) +-- | For internal testing +pattern :: MkFunc -> CharParser () Pattern +pattern mkFunc = char '*' *> ( + (char '=' *> newContains (ws *> _expr mkFunc)) <|> return ZAny - ) <|> _parenPattern + ) <|> _parenPattern mkFunc <|> _refPattern <|> try _emptyPattern - <|> try _treenodePattern - <|> try _depthPattern - <|> _notPattern + <|> try (_treenodePattern mkFunc) + <|> try (_depthPattern mkFunc) + <|> _notPattern mkFunc -_patternDecl :: CharParser () Refs -_patternDecl = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern) +_patternDecl :: MkFunc -> CharParser () Grammar +_patternDecl mkFunc = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern mkFunc) -grammar :: CharParser () Refs -grammar = ws *> (foldl1 union <$> many1 (_patternDecl <* ws)) - <|> union <$> (newRef "main" <$> pattern) <*> (foldl union emptyRef <$> many (ws *> _patternDecl <* ws)) +-- | For internal testing +grammar :: MkFunc -> CharParser () Grammar +grammar mkFunc = ws *> (foldl1 union <$> many1 (_patternDecl mkFunc <* ws)) + <|> union <$> (newRef "main" <$> pattern mkFunc) <*> (foldl union emptyRef <$> many (ws *> _patternDecl mkFunc <* ws)) diff --git a/src/Parsers.hs b/src/Parsers.hs --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -11,13 +11,24 @@ import Control.DeepSeq (NFData) import GHC.Generics (Generic) +import Data.Text (Text) +import Data.ByteString (ByteString) +-- | +-- Label is a tagged union of all possible value types that can returned by a katydid parser: +-- String, Int, Uint, Double, Bool and Bytes. data Label - = String String - | Number Rational + = String Text + | Int Int + | Uint Word + | Double Double | Bool Bool + | Bytes ByteString deriving (Show, Eq, Ord, Generic, NFData) +-- | +-- Tree is the type class that should be implemented by a katydid parser. +-- This is implemented by the Json and XML parser. class Tree a where getLabel :: a -> Label getChildren :: a -> [a] diff --git a/src/Patterns.hs b/src/Patterns.hs deleted file mode 100644 --- a/src/Patterns.hs +++ /dev/null @@ -1,109 +0,0 @@ --- | --- This module describes the patterns supported by Relapse. --- --- It also contains some simple functions for the map of references that a Relapse grammar consists of. --- --- Finally it also contains some very simple pattern functions. -module Patterns ( - Pattern(..), - Refs, emptyRef, union, newRef, reverseLookupRef, lookupRef, hasRecursion, - nullable, unescapable -) where - -import qualified Data.Map.Strict as M -import qualified Data.Set as S - -import Expr - --- | --- Pattern recursively describes a Relapse Pattern. -data Pattern - = Empty - | ZAny - | Node (Expr Bool) Pattern - | Or Pattern Pattern - | And Pattern Pattern - | Not Pattern - | Concat Pattern Pattern - | Interleave Pattern Pattern - | ZeroOrMore Pattern - | Optional Pattern - | Contains Pattern - | Reference String - deriving (Eq, Ord, Show) - --- | --- The nullable function returns whether a pattern is nullable. --- This means that the pattern matches the empty string. -nullable :: Refs -> Pattern -> Bool -nullable _ Empty = True -nullable _ ZAny = True -nullable _ Node{} = False -nullable refs (Or l r) = nullable refs l || nullable refs r -nullable refs (And l r) = nullable refs l && nullable refs r -nullable refs (Not p) = not $ nullable refs p -nullable refs (Concat l r) = nullable refs l && nullable refs r -nullable refs (Interleave l r) = nullable refs l && nullable refs r -nullable _ (ZeroOrMore _) = True -nullable _ (Optional _) = True -nullable refs (Contains p) = nullable refs p -nullable refs (Reference name) = nullable refs $ lookupRef refs name - --- | --- unescapable is used for short circuiting. --- A part of the tree can be skipped if all patterns are unescapable. -unescapable :: Pattern -> Bool -unescapable ZAny = True -unescapable (Not ZAny) = True -unescapable _ = False - --- | --- Refs is a map from reference name to pattern and describes a relapse grammar. -newtype Refs = Refs (M.Map String Pattern) - deriving (Show, Eq) - --- | --- lookupRef looks up a pattern in the reference map, given a reference name. -lookupRef :: Refs -> String -> Pattern -lookupRef (Refs m) name = m M.! name - --- | --- reverseLookupRef returns the reference name for a given pattern. -reverseLookupRef :: Pattern -> Refs -> Maybe String -reverseLookupRef p (Refs m) = case M.keys $ M.filter (== p) m of - [] -> Nothing - (k:_) -> Just k - --- | --- newRef returns a new reference map given a single pattern and its reference name. -newRef :: String -> Pattern -> Refs -newRef key value = Refs $ M.singleton key value - --- | --- emptyRef returns an empty reference map. -emptyRef :: Refs -emptyRef = Refs M.empty - --- | --- union returns the union of two reference maps. -union :: Refs -> Refs -> Refs -union (Refs m1) (Refs m2) = Refs $ M.union m1 m2 - --- | --- hasRecursion returns whether an relapse grammar has any recursion, starting from the "main" reference. -hasRecursion :: Refs -> Bool -hasRecursion refs = hasRec refs (S.singleton "main") (lookupRef refs "main") - -hasRec :: Refs -> S.Set String -> Pattern -> Bool -hasRec _ _ Empty = False -hasRec _ _ ZAny = False -hasRec _ _ Node{} = False -hasRec refs set (Or l r) = hasRec refs set l || hasRec refs set r -hasRec refs set (And l r) = hasRec refs set l || hasRec refs set r -hasRec refs set (Not p) = hasRec refs set p -hasRec refs set (Concat l r) = hasRec refs set l || (nullable refs l && hasRec refs set r) -hasRec refs set (Interleave l r) = hasRec refs set l || hasRec refs set r -hasRec _ _ (ZeroOrMore _) = False -hasRec refs set (Optional p) = hasRec refs set p -hasRec refs set (Contains p) = hasRec refs set p -hasRec refs set (Reference name) = S.member name set || hasRec refs (S.insert name set) (lookupRef refs name) diff --git a/src/Relapse.hs b/src/Relapse.hs --- a/src/Relapse.hs +++ b/src/Relapse.hs @@ -14,39 +14,53 @@ -- If your tree has a single root, simply provide a singleton list as input. module Relapse ( - parseGrammar, validate, filter + parse, parseWithUDFs, Grammar + , validate, filter ) where import Prelude hiding (filter) -import Control.Monad.Except (Except, throwError, return) import Control.Monad.State (runState) import Control.Monad (filterM) import qualified Parser -import Patterns (Refs) -import qualified Patterns +import qualified Ast import qualified MemDerive +import qualified Smart import Parsers +import qualified Exprs +-- | Grammar represents a compiled relapse grammar. +newtype Grammar = Grammar Smart.Grammar + -- | --- parseGrammar parses the relapse grammar and returns either a parsed grammar (Refs, for the list of references) or an error string. -parseGrammar :: String -> Except String Refs -parseGrammar grammarString = case Parser.parseGrammar grammarString of - (Left l) -> throwError (show l) - (Right r) -> return r +-- parse parses the relapse grammar and returns either a parsed grammar or an error string. +parse :: String -> Either String Grammar +parse grammarString = do { + parsed <- Parser.parseGrammar grammarString; + Grammar <$> Smart.compile parsed; +} -- | --- validate returns whether a tree is valid, given the grammar (Refs). -validate :: Tree t => Refs -> [t] -> Bool -validate refs tree = case filter refs [tree] of +-- parseWithUDFs parses the relapse grammar with extra user defined functions +-- and returns either a parsed grammar or an error string. +parseWithUDFs :: Exprs.MkFunc -> String -> Either String Grammar +parseWithUDFs userLib grammarString = do { + parsed <- Parser.parseGrammarWithUDFs userLib grammarString; + Grammar <$> Smart.compile parsed; +} + +-- | +-- validate returns whether a tree is valid, given the grammar. +validate :: Tree t => Grammar -> [t] -> Bool +validate g tree = case filter g [tree] of [] -> False _ -> True -- | --- filter returns a filtered list of trees, given the grammar (Refs). -filter :: Tree t => Refs -> [[t]] -> [[t]] -filter refs trees = - let start = Patterns.lookupRef refs "main" - f = filterM (MemDerive.validate refs start) trees +-- filter returns a filtered list of trees, given the grammar. +filter :: Tree t => Grammar -> [[t]] -> [[t]] +filter (Grammar g) trees = + let start = Smart.lookupMain g + f = filterM (MemDerive.validate g start) trees (r, _) = runState f MemDerive.newMem in r diff --git a/src/Simplify.hs b/src/Simplify.hs --- a/src/Simplify.hs +++ b/src/Simplify.hs @@ -9,21 +9,22 @@ import qualified Data.Set as S -import Patterns +import Ast import Expr +import Exprs.Logic -- | -- simplify simplifies an input pattern to an equivalent simpler pattern. -simplify :: Refs -> Pattern -> Pattern -simplify refs pattern = - let simp = simplify' refs - in case pattern of +simplify :: Grammar -> Pattern -> Pattern +simplify g pat = + let simp = simplify' g + in case pat of Empty -> Empty ZAny -> ZAny - (Node v p) -> simplifyNode (simplifyBoolExpr v) (simp p) + (Node v p) -> simplifyNode v (simp p) (Concat p1 p2) -> simplifyConcat (simp p1) (simp p2) - (Or p1 p2) -> simplifyOr refs (simp p1) (simp p2) - (And p1 p2) -> simplifyAnd refs (simp p1) (simp p2) + (Or p1 p2) -> simplifyOr g (simp p1) (simp p2) + (And p1 p2) -> simplifyAnd g (simp p1) (simp p2) (ZeroOrMore p) -> simplifyZeroOrMore (simp p) (Not p) -> simplifyNot (simp p) (Optional p) -> simplifyOptional (simp p) @@ -31,12 +32,13 @@ (Contains p) -> simplifyContains (simp p) p@(Reference _) -> p -simplify' :: Refs -> Pattern -> Pattern -simplify' refs p = checkRef refs $ simplify refs p +simplify' :: Grammar -> Pattern -> Pattern +simplify' g p = checkRef g $ simplify g p simplifyNode :: Expr Bool -> Pattern -> Pattern -simplifyNode (Const False) _ = Not ZAny -simplifyNode v p = Node v p +simplifyNode v p = case evalConst v of + (Just False) -> Not ZAny + _ -> Node v p simplifyConcat :: Pattern -> Pattern -> Pattern simplifyConcat (Not ZAny) _ = Not ZAny @@ -48,17 +50,17 @@ simplifyConcat ZAny (Concat p ZAny) = Contains p simplifyConcat p1 p2 = Concat p1 p2 -simplifyOr :: Refs -> Pattern -> Pattern -> Pattern +simplifyOr :: Grammar -> Pattern -> Pattern -> Pattern simplifyOr _ (Not ZAny) p = p simplifyOr _ p (Not ZAny) = p simplifyOr _ ZAny _ = ZAny simplifyOr _ _ ZAny = ZAny -simplifyOr _ (Node v1 Empty) (Node v2 Empty) = Node (OrFunc v1 v2) Empty -simplifyOr refs Empty p - | nullable refs p = p +simplifyOr _ (Node v1 Empty) (Node v2 Empty) = Node (orExpr v1 v2) Empty +simplifyOr g Empty p + | nullable g p == Right True = p | otherwise = Or Empty p -simplifyOr refs p Empty - | nullable refs p = p +simplifyOr g p Empty + | nullable g p == Right True = p | otherwise = Or Empty p simplifyOr _ p1 p2 = bin Or $ simplifyChildren Or $ S.toAscList $ setOfOrs p1 `S.union` setOfOrs p2 @@ -79,17 +81,17 @@ setOfOrs (Or p1 p2) = setOfOrs p1 `S.union` setOfOrs p2 setOfOrs p = S.singleton p -simplifyAnd :: Refs -> Pattern -> Pattern -> Pattern +simplifyAnd :: Grammar -> Pattern -> Pattern -> Pattern simplifyAnd _ (Not ZAny) _ = Not ZAny simplifyAnd _ _ (Not ZAny) = Not ZAny simplifyAnd _ ZAny p = p simplifyAnd _ p ZAny = p -simplifyAnd _ (Node v1 Empty) (Node v2 Empty) = Node (AndFunc v1 v2) Empty -simplifyAnd refs Empty p - | nullable refs p = Empty +simplifyAnd _ (Node v1 Empty) (Node v2 Empty) = Node (andExpr v1 v2) Empty +simplifyAnd g Empty p + | nullable g p == Right True = Empty | otherwise = Not ZAny -simplifyAnd refs p Empty - | nullable refs p = Empty +simplifyAnd g p Empty + | nullable g p == Right True = Empty | otherwise = Not ZAny simplifyAnd _ p1 p2 = bin And $ simplifyChildren And $ S.toAscList $ setOfAnds p1 `S.union` setOfAnds p2 @@ -127,8 +129,8 @@ simplifyContains (Not ZAny) = Not ZAny simplifyContains p = Contains p -checkRef :: Refs -> Pattern -> Pattern -checkRef refs p = case reverseLookupRef p refs of +checkRef :: Grammar -> Pattern -> Pattern +checkRef g p = case reverseLookupRef p g of Nothing -> p (Just k) -> Reference k diff --git a/src/Smart.hs b/src/Smart.hs new file mode 100644 --- /dev/null +++ b/src/Smart.hs @@ -0,0 +1,417 @@ +-- | +-- This module describes the smart constructors for Relapse patterns. +module Smart ( + Pattern(..) + , Grammar + , lookupRef + , compile + , emptyPat, zanyPat, nodePat + , orPat, andPat, notPat + , concatPat, interleavePat + , zeroOrMorePat, optionalPat + , containsPat, refPat + , emptySet + , unescapable + , nullable + , lookupMain +) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.List (sort, sortBy, intercalate) +import Control.Monad (when) + +import qualified Expr +import Exprs.Logic (orExpr, andExpr) +import qualified Ast + +-- | compile complies an ast into a smart grammar. +compile :: Ast.Grammar -> Either String Grammar +compile g = do { + Ast.lookupRef g "main"; -- making sure that the main reference exists. + hasRec <- Ast.hasRecursion g; + when hasRec $ Left "recursion without interleaved treenode not supported"; + refs <- M.fromList <$> mapM (\name -> do { + p <- Ast.lookupRef g name; + return (name, p) + }) (Ast.listRefs g); + nullRefs <- mapM (Ast.nullable g) refs; + Grammar <$> mapM (smart nullRefs) refs +} + +smart :: M.Map String Bool -> Ast.Pattern -> Either String Pattern +smart _ Ast.Empty = return emptyPat +smart nulls (Ast.Node e p) = nodePat e <$> smart nulls p +smart nulls (Ast.Concat a b) = concatPat <$> smart nulls a <*> smart nulls b +smart nulls (Ast.Or a b) = orPat <$> smart nulls a <*> smart nulls b +smart nulls (Ast.And a b) = andPat <$> smart nulls a <*> smart nulls b +smart nulls (Ast.ZeroOrMore p) = zeroOrMorePat <$> smart nulls p +smart nulls (Ast.Reference name) = refPat nulls name +smart nulls (Ast.Not p) = notPat <$> smart nulls p +smart _ Ast.ZAny = return zanyPat +smart nulls (Ast.Contains p) = containsPat <$> smart nulls p +smart nulls (Ast.Optional p) = optionalPat <$> smart nulls p +smart nulls (Ast.Interleave a b) = interleavePat <$> smart nulls a <*> smart nulls b + +-- | +-- Pattern recursively describes a Relapse Pattern. +data Pattern = Empty + | Node { + expr :: Expr.Expr Bool + , pat :: Pattern + , _hash :: Int + } + | Concat { + left :: Pattern + , right :: Pattern + , _nullable :: Bool + , _hash :: Int + } + | Or { + pats :: [Pattern] + , _nullable :: Bool + , _hash :: Int + } + | And { + pats :: [Pattern] + , _nullable :: Bool + , _hash :: Int + } + | ZeroOrMore { + pat :: Pattern + , _hash :: Int + } + | Reference { + refName :: ValidRef + , _nullable :: Bool + , _hash :: Int + } + | Not { + pat :: Pattern + , _nullable :: Bool + , _hash :: Int + } + | ZAny + | Contains { + pat :: Pattern + , _nullable :: Bool + , _hash :: Int + } + | Optional { + pat :: Pattern + , _hash :: Int + } + | Interleave { + pats :: [Pattern] + , _nullable :: Bool + , _hash :: Int + } + deriving (Eq, Ord) + +instance Show Pattern where + show = toStr + +toStr :: Pattern -> String +toStr Empty = "" +toStr Node{expr=e, pat=p} = show e ++ ":" ++ show p +toStr Concat{left=l,right=r} = "[" ++ show l ++ "," ++ show r ++ "]" +toStr Or{pats=ps} = "(" ++ intercalate "|" (map show ps) ++ ")" +toStr And{pats=ps} = "(" ++ intercalate "&" (map show ps) ++ ")" +toStr ZeroOrMore{pat=p} = "(" ++ show p ++ ")*" +toStr Reference{refName=(ValidRef n)} = "@"++n +toStr Not{pat=p} = "!(" ++ show p ++ ")" +toStr ZAny = "*" +toStr Contains{pat=p} = "." ++ show p +toStr Optional{pat=p} = "(" ++ show p ++ ")?" +toStr Interleave{pats=ps} = "{" ++ intercalate ";" (map show ps) ++ "}" + +-- cmp is an efficient comparison function for patterns. +-- It is very important that cmp is efficient, +-- because it is a bottleneck for simplification and smart construction of large queries. +cmp :: Pattern -> Pattern -> Ordering +cmp a b = if hashcmp == EQ then compare a b else hashcmp + where hashcmp = compare (hash a) (hash b) + +-- eq is an efficient comparison function for patterns. +-- It is very important that eq is efficient, +-- because it is a bottleneck for simplification and smart construction of large queries. +eq :: Pattern -> Pattern -> Bool +eq a b = cmp a b == EQ + +hash :: Pattern -> Int +hash Empty = 3 +hash Node{_hash=h} = h +hash Concat{_hash=h} = h +hash Or{_hash=h} = h +hash And{_hash=h} = h +hash ZeroOrMore{_hash=h} = h +hash Reference{_hash=h} = h +hash Not{_hash=h} = h +hash ZAny = 5 +hash Contains{_hash=h} = h +hash Optional{_hash=h} = h +hash Interleave{_hash=h} = h + +-- | nullable returns whether the pattern matches the empty string. +nullable :: Pattern -> Bool +nullable Empty = True +nullable Node{} = False +nullable Concat{_nullable=n} = n +nullable Or{_nullable=n} = n +nullable And{_nullable=n} = n +nullable ZeroOrMore{} = True +nullable Reference{_nullable=n} = n +nullable Not{_nullable=n} = n +nullable ZAny = True +nullable Contains{_nullable=n} = n +nullable Optional{} = True +nullable Interleave{_nullable=n} = n + +-- | emptyPat is the smart constructor for the empty pattern. +emptyPat :: Pattern +emptyPat = Empty + +-- | zanyPat is the smart constructor for the zany pattern. +zanyPat :: Pattern +zanyPat = ZAny + +-- | notPat is the smart constructor for the not pattern. +notPat :: Pattern -> Pattern +notPat Not {pat=p} = p +notPat p = Not { + pat = p + , _nullable = not $ nullable p + , _hash = 31 * 7 + hash p +} + +-- | emptySet is the smart constructor for the !(*) pattern. +emptySet :: Pattern +emptySet = notPat zanyPat + +-- | nodePat is the smart constructor for the node pattern. +nodePat :: Expr.Expr Bool -> Pattern -> Pattern +nodePat e p = + case Expr.evalConst e of + (Just False) -> emptySet + _ -> Node { + expr = e + , pat = p + , _hash = 31 * (11 + 31 * Expr._hash (Expr.desc e)) + hash p + } + +isLeaf :: Pattern -> Bool +isLeaf Node{pat=Empty} = True +isLeaf _ = False + +-- | concatPat is the smart constructor for the concat pattern. +concatPat :: Pattern -> Pattern -> Pattern +concatPat notZAny@Not{pat=ZAny} _ = notZAny +concatPat _ notZAny@Not{pat=ZAny} = notZAny +concatPat Empty b = b +concatPat a Empty = a +concatPat Concat{left=a1, right=a2} b = concatPat a1 (concatPat a2 b) +concatPat ZAny Concat{left=b1, right=ZAny} = containsPat b1 +concatPat a b = Concat { + left = a + , right = b + , _nullable = nullable a && nullable b + , _hash = 31 * (13 + 31 * hash a) + hash b +} + +-- | containsPat is the smart constructor for the contains pattern. +containsPat :: Pattern -> Pattern +containsPat Empty = ZAny +containsPat p@ZAny = p +containsPat p@Not{pat=ZAny} = p +containsPat p = Contains { + pat = p + , _nullable = nullable p + , _hash = 31 * 17 + hash p +} + +-- | optionalPat is the smart constructor for the optional pattern. +optionalPat :: Pattern -> Pattern +optionalPat p@Empty = p +optionalPat p@Optional{} = p +optionalPat p = Optional { + pat = p + , _hash = 31 * 19 + hash p +} + +-- | zeroOrMorePat is the smart constructor for the zeroOrMore pattern. +zeroOrMorePat :: Pattern -> Pattern +zeroOrMorePat p@ZeroOrMore{} = p +zeroOrMorePat p = ZeroOrMore { + pat = p + , _hash = 31 * 23 + hash p +} + +-- | refPat is the smart constructor for the reference pattern. +refPat :: M.Map String Bool -> String -> Either String Pattern +refPat nullRefs name = + case M.lookup name nullRefs of + Nothing -> Left $ "no reference named: " ++ name + (Just n) -> Right Reference { + refName = ValidRef name + , _hash = 31 * 29 + Expr.hashString name + , _nullable = n + } + +-- | orPat is the smart constructor for the or pattern. +orPat :: Pattern -> Pattern -> Pattern +orPat a b = orPat' $ S.fromList (getOrs a ++ getOrs b) + +getOrs :: Pattern -> [Pattern] +getOrs Or{pats=ps} = ps +getOrs p = [p] + +orPat' :: S.Set Pattern -> Pattern +orPat' ps = ps `returnIfSingleton` + \ps -> if S.member zanyPat ps + then zanyPat + else S.delete emptySet ps `returnIfSingleton` + \ps -> (if all nullable ps + then S.delete emptyPat ps + else ps) `returnIfSingleton` + \ps -> mergeLeaves orExpr ps `returnIfSingleton` + \ps -> mergeNodesWithEqualNames orPat ps `returnIfSingleton` + \ps -> let psList = sort $ S.toList ps + in Or { + pats = psList + , _nullable = any nullable psList + , _hash = Expr.hashList (31*33) $ map hash psList + } + +-- | andPat is the smart constructor for the and pattern. +andPat :: Pattern -> Pattern -> Pattern +andPat a b = andPat' $ S.fromList (getAnds a ++ getAnds b) + +getAnds :: Pattern -> [Pattern] +getAnds And{pats=ps} = ps +getAnds p = [p] + +andPat' :: S.Set Pattern -> Pattern +andPat' ps = ps `returnIfSingleton` + \ps -> if S.member emptySet ps + then emptySet + else S.delete zanyPat ps `returnIfSingleton` + \ps -> if S.member emptyPat ps + then if all nullable ps + then emptyPat + else emptySet + else ps `returnIfSingleton` + \ps -> mergeLeaves andExpr ps `returnIfSingleton` + \ps -> mergeNodesWithEqualNames andPat ps `returnIfSingleton` + \ps -> let psList = sort $ S.toList ps + in And { + pats = psList + , _nullable = all nullable psList + , _hash = Expr.hashList (31*37) $ map hash psList + } + +-- | returnIfSingleton returns the pattern from the set if the set is of size one, otherwise it applies the function to the set. +returnIfSingleton :: S.Set Pattern -> (S.Set Pattern -> Pattern) -> Pattern +returnIfSingleton s1 f = + if S.size s1 == 1 then head $ S.toList s1 else f s1 + +mergeLeaves :: (Expr.Expr Bool -> Expr.Expr Bool -> Expr.Expr Bool) -> S.Set Pattern -> S.Set Pattern +mergeLeaves merger = merge $ \a b -> case (a,b) of + (Node{expr=ea,pat=Empty},Node{expr=eb,pat=Empty}) -> [nodePat (merger ea eb) emptyPat] + _ -> [a,b] + +mergeNodesWithEqualNames :: (Pattern -> Pattern -> Pattern) -> S.Set Pattern -> S.Set Pattern +mergeNodesWithEqualNames merger = merge $ \a b -> case (a,b) of + (Node{expr=ea,pat=pa},Node{expr=eb,pat=pb}) -> + if ea == eb then [nodePat ea (merger pa pb)] else [a,b] + _ -> [a,b] + +merge :: (Pattern -> Pattern -> [Pattern]) -> S.Set Pattern -> S.Set Pattern +merge merger ps = let list = sortBy leavesThenNamesAndThenContains (S.toList ps) + in S.fromList $ foldl (\(a:merged) b -> merger a b ++ merged) [head list] (tail list) + +leavesThenNamesAndThenContains :: Pattern -> Pattern -> Ordering +leavesThenNamesAndThenContains a@Node{} b@Node{} = leavesFirst a b +leavesThenNamesAndThenContains Node{} _ = LT +leavesThenNamesAndThenContains _ Node{} = GT +leavesThenNamesAndThenContains a b = containsThird a b + +leavesFirst :: Pattern -> Pattern -> Ordering +leavesFirst a b + | isLeaf a && isLeaf b = compare a b + | isLeaf a = LT + | isLeaf b = GT + | otherwise = namesSecond a b + +namesSecond :: Pattern -> Pattern -> Ordering +namesSecond a@Node{expr=ea} b@Node{expr=eb} = let fcomp = compare ea eb + in if fcomp == EQ + then compare a b + else fcomp + +containsThird :: Pattern -> Pattern -> Ordering +containsThird a@Contains{} b@Contains{} = compare a b +containsThird Contains{} _ = LT +containsThird _ Contains{} = GT +containsThird a b = compare a b + +-- | interleavePat is the smart constructor for the interleave pattern. +interleavePat :: Pattern -> Pattern -> Pattern +interleavePat a b = interleavePat' (getInterleaves a ++ getInterleaves b) + +getInterleaves :: Pattern -> [Pattern] +getInterleaves Interleave{pats=ps} = ps +getInterleaves p = [p] + +interleavePat' :: [Pattern] -> Pattern +interleavePat' ps + | emptySet `elem` ps = emptySet + | all (eq Empty) ps = emptyPat + | otherwise = delete Empty ps `returnIfOnlyOne` + \ps -> (if any (eq ZAny) ps + then zanyPat : delete ZAny ps + else ps) `returnIfOnlyOne` + \ps -> let psList = sort ps + in Interleave { + pats = psList + , _nullable = all nullable psList + , _hash = Expr.hashList (31*41) $ map hash psList + } + +-- | returnIfOnlyOne returns the pattern from the list if the list is of size one, otherwise it applies the function to the list. +returnIfOnlyOne :: [Pattern] -> ([Pattern] -> Pattern) -> Pattern +returnIfOnlyOne xs f = if length xs == 1 then head xs else f xs + +delete :: Pattern -> [Pattern] -> [Pattern] +delete removeItem = filter (not . (\p -> p == removeItem)) + +-- | +-- unescapable is used for short circuiting. +-- A part of the tree can be skipped if all patterns are unescapable. +unescapable :: Pattern -> Bool +unescapable ZAny = True +unescapable Not{pat=ZAny} = True +unescapable _ = False + +-- | +-- Grammar is a map from reference name to pattern and describes a relapse grammar. +newtype Grammar = Grammar Refs + deriving (Show, Eq) + +-- | +-- Refs is a map from reference name to pattern, excluding the main reference, which makes a relapse grammar. +type Refs = M.Map String Pattern + +newtype ValidRef = ValidRef String + deriving (Eq, Ord, Show) + +-- | +-- lookupRef looks up a pattern in the reference map, given a reference name. +lookupRef :: Grammar -> ValidRef -> Pattern +lookupRef (Grammar refs) (ValidRef name) = + case M.lookup name refs of + Nothing -> error $ "valid reference not found: " ++ name + (Just p) -> p + +-- | lookupMain retrieves the main pattern from the grammar. +lookupMain :: Grammar -> Pattern +lookupMain g = lookupRef g (ValidRef "main") diff --git a/src/VpaDerive.hs b/src/VpaDerive.hs --- a/src/VpaDerive.hs +++ b/src/VpaDerive.hs @@ -1,9 +1,9 @@ -- | --- This module contains a VPA (Visual Pushdown Automaton) implementation of the internal derivative algorithm. +-- This module contains a VPA (Visibly Pushdown Automaton) implementation of the internal derivative algorithm. -- -- It is intended to be used for explanation purposes. -- --- It shows how out algorithm is effective equivalent to a visual pushdown automaton. +-- It shows how our algorithm is effectively equivalent to a visibly pushdown automaton. module VpaDerive ( derive @@ -12,11 +12,11 @@ import qualified Data.Map.Strict as M import Control.Monad.State (State, runState, state, lift) import Data.Foldable (foldlM) -import Control.Monad.Except (Except, ExceptT, throwError, runExcept, runExceptT) +import Control.Monad.Trans.Either (EitherT, runEitherT, left, hoistEither) import qualified Derive -import Patterns (Refs, Pattern) -import qualified Patterns +import Smart (Grammar, Pattern) +import qualified Smart import IfExprs import Expr import Zip @@ -35,36 +35,34 @@ type Nullable = M.Map [Pattern] [Bool] type Returns = M.Map ([Pattern], Zipper, [Bool]) [Pattern] -newtype Vpa = Vpa (Nullable, Calls, Returns, Refs) +newtype Vpa = Vpa (Nullable, Calls, Returns, Grammar) -newVpa :: Refs -> Vpa -newVpa refs = Vpa (M.empty, M.empty, M.empty, refs) +newVpa :: Grammar -> Vpa +newVpa g = Vpa (M.empty, M.empty, M.empty, g) nullable :: [Pattern] -> State Vpa [Bool] -nullable key = state $ \(Vpa (n, c, r, refs)) -> let (v', n') = mem (map $ Patterns.nullable refs) key n; - in (v', Vpa (n', c, r, refs)) +nullable key = state $ \(Vpa (n, c, r, g)) -> let (v', n') = mem (map Smart.nullable) key n; + in (v', Vpa (n', c, r, g)) calls :: [Pattern] -> State Vpa ZippedIfExprs -calls key = state $ \(Vpa (n, c, r, refs)) -> let (v', c') = mem (zipIfExprs . Derive.calls refs) key c; - in (v', Vpa (n, c', r, refs)) +calls key = state $ \(Vpa (n, c, r, g)) -> let (v', c') = mem (zipIfExprs . Derive.calls g) key c; + in (v', Vpa (n, c', r, g)) -vpacall :: VpaState -> Label -> ExceptT ValueErr (State Vpa) (StackElm, VpaState) +vpacall :: VpaState -> Label -> EitherT String (State Vpa) (StackElm, VpaState) vpacall vpastate label = do { zifexprs <- lift $ calls vpastate; - (nextstate, zipper) <- case runExcept $ evalZippedIfExprs zifexprs label of - (Left l) -> throwError l - (Right r) -> return r - ; - let stackelm = (vpastate, zipper) + (nextstate, zipper) <- hoistEither $ evalZippedIfExprs zifexprs label; + let + stackelm = (vpastate, zipper) ; return (stackelm, nextstate) } returns :: ([Pattern], Zipper, [Bool]) -> State Vpa [Pattern] -returns key = state $ \(Vpa (n, c, r, refs)) -> +returns key = state $ \(Vpa (n, c, r, g)) -> let (v', r') = mem (\(ps, zipper, znulls) -> - Derive.returns refs (ps, unzipby zipper znulls)) key r - in (v', Vpa (n, c, r', refs)) + Derive.returns g (ps, unzipby zipper znulls)) key r + in (v', Vpa (n, c, r', g)) vpareturn :: StackElm -> VpaState -> State Vpa VpaState vpareturn (vpastate, zipper) current = do { @@ -72,25 +70,28 @@ returns (vpastate, zipper, zipnulls) } -deriv :: Tree t => VpaState -> t -> ExceptT ValueErr (State Vpa) VpaState +deriv :: Tree t => VpaState -> t -> EitherT String (State Vpa) VpaState deriv current tree = do { (stackelm, nextstate) <- vpacall current (getLabel tree); resstate <- foldlM deriv nextstate (getChildren tree); lift $ vpareturn stackelm resstate } -foldLT :: Tree t => Vpa -> VpaState -> [t] -> Except ValueErr [Pattern] +foldLT :: Tree t => Vpa -> VpaState -> [t] -> Either String [Pattern] foldLT _ current [] = return current foldLT m current (t:ts) = - let (newstate, newm) = runState (runExceptT $ deriv current t) m + let (newstate, newm) = runState (runEitherT $ deriv current t) m in case newstate of - (Left l) -> throwError l + (Left l) -> Left l (Right r) -> foldLT newm r ts -derive :: Tree t => Refs -> [t] -> Except String Pattern -derive refs ts = - let start = [Patterns.lookupRef refs "main"] - in case runExcept $ foldLT (newVpa refs) start ts of - (Left l) -> throwError $ show l +-- | +-- derive is the derivative implementation for trees. +-- This implementation makes use of visual pushdown automata. +derive :: Tree t => Grammar -> [t] -> Either String Pattern +derive g ts = + let start = [Smart.lookupMain g] + in case foldLT (newVpa g) start ts of + (Left l) -> Left $ show l (Right [r]) -> return r - (Right rs) -> throwError $ "Number of patterns is not one, but " ++ show rs + (Right rs) -> Left $ "Number of patterns is not one, but " ++ show rs diff --git a/src/Xml.hs b/src/Xml.hs --- a/src/Xml.hs +++ b/src/Xml.hs @@ -11,11 +11,12 @@ import Text.XML.HXT.DOM.TypeDefs (XmlTree, XNode(..), blobToString, localPart) import Text.XML.HXT.Parser.XmlParsec (xread) import Data.Tree.NTree.TypeDefs (NTree(..)) +import qualified Data.Text as Text import Parsers instance Tree XmlTree where - getLabel (NTree n _ ) = either (String . ("XML Parse Error:" ++)) id (xmlLabel n) + getLabel (NTree n _ ) = either (String . Text.pack . ("XML Parse Error:" ++)) id (xmlLabel n) getChildren (NTree _ cs) = cs -- | @@ -38,4 +39,4 @@ -- TODO what about other leaf types parseLabel :: String -> Label -parseLabel s = maybe (String s) (Number . toRational) (readMaybe s :: Maybe Int) +parseLabel s = maybe (String (Text.pack s)) Int (readMaybe s :: Maybe Int) diff --git a/src/Zip.hs b/src/Zip.hs --- a/src/Zip.hs +++ b/src/Zip.hs @@ -10,28 +10,34 @@ import qualified Data.Set as S import Data.List (elemIndex) -import Patterns +import Smart data ZipEntry = ZipVal Int | ZipZAny | ZipNotZAny deriving (Eq, Ord) +-- | +-- Zipper represents compressed indexes +-- that resulted from compressing a list of patterns. +-- This can be used to uncompress a list of bools (nullability of patterns). newtype Zipper = Zipper [ZipEntry] deriving (Eq, Ord) +-- | zippy compresses a list of patterns. zippy :: [Pattern] -> ([Pattern], Zipper) zippy ps = let s = S.fromList ps s' = S.delete ZAny s - s'' = S.delete (Not ZAny) s' + s'' = S.delete emptySet s' l = S.toAscList s'' in (l, Zipper $ map (indexOf l) ps) indexOf :: [Pattern] -> Pattern -> ZipEntry indexOf _ ZAny = ZipZAny -indexOf _ (Not ZAny) = ZipNotZAny +indexOf _ Not{pat=ZAny} = ZipNotZAny indexOf ps p = case elemIndex p ps of (Just i) -> ZipVal i +-- | unzipby uncompresses a list of bools (nullability of patterns). unzipby :: Zipper -> [Bool] -> [Bool] unzipby (Zipper z) bs = map (ofIndexb bs) z diff --git a/test/DeriveSpec.hs b/test/DeriveSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeriveSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- This module DeriveSpec tests the Derive module. +module DeriveSpec ( + tests +) where + +import qualified Test.Tasty as T +import qualified Test.Tasty.HUnit as HUnit + +import Data.Tree +import qualified Derive +import qualified Parser +import qualified Smart +import qualified Parsers + +import Data.List.Index (imap) + +instance Parsers.Tree (Tree Parsers.Label) where + getLabel (Node l _) = l + getChildren (Node _ cs) = cs + +tests = T.testGroup "Derive" [ + T.testGroup "derive" [ + HUnit.testCase "two ors" $ + either HUnit.assertFailure (\(want,got) -> HUnit.assertEqual "(want,got)" want got) $ do { + input <- Parser.parseGrammar "(== 1 | !(== 2))" >>= Smart.compile; + want <- Parser.parseGrammar "*" >>= Smart.compile; + got <- Derive.derive input [Node (Parsers.Int 1) []]; + return (Smart.lookupMain want, got) + } + , HUnit.testCase "two interleaves" $ + either HUnit.assertFailure (\(want,got) -> HUnit.assertEqual "(want,got)" want got) $ do { + input <- Parser.parseGrammar "{== 1 ; !(== 2)}" >>= Smart.compile; + want <- Parser.parseGrammar "({;!(==2)}|{==1;*})" >>= Smart.compile; + got <- Derive.derive input [Node (Parsers.Int 1) []]; + return (Smart.lookupMain want, got) + } + ] + , T.testGroup "removeOneForEach" [ + HUnit.testCase "[1,2]" $ + HUnit.assertEqual "1,2" [[2],[1]] $ Derive.removeOneForEach [1,2] + , HUnit.testCase "[1,2,3]" $ + HUnit.assertEqual "1,2,3" [[2,3],[1,3],[1,2]] $ Derive.removeOneForEach [1,2,3] + , HUnit.testCase "[1]" $ + HUnit.assertEqual "1" [[]] $ Derive.removeOneForEach [1] + ]] diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs --- a/test/ParserSpec.hs +++ b/test/ParserSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- This module ParserSpec tests the Parser module. module ParserSpec ( @@ -11,8 +13,19 @@ import Parser import Expr -import Patterns +import Exprs.Compare +import Exprs.Contains +import Exprs.Elem +import Exprs.Length +import Exprs.Logic +import Exprs.Strings +import Exprs.Type +import Exprs.Var +import Exprs +import Ast +import UserDefinedFuncs + success :: (Eq a, Show a) => String -> CharParser () a -> String -> a -> T.TestTree success name p input want = HUnit.testCase name $ case parse (p <* eof) "" input of (Left err) -> HUnit.assertFailure $ "given input: " ++ input ++ " got error: " ++ show err @@ -86,109 +99,115 @@ success "id with underscore" idLit "abc_123" "abc_123", failure "id starts with number" idLit "123abc", - success "expr bool var" expr "$bool" BoolVariable, - success "expr bool const" expr "true" (Const True), - success "expr ==" expr "== true" (BoolEqualFunc BoolVariable (Const True)), - success "expr *=" expr "*= \"a\"" (StringContainsFunc StringVariable (Const "a")), - success "expr not" expr "not(true)" (NotFunc (Const True)), - success "expr eq bool" expr "eq($bool, true)" (BoolEqualFunc BoolVariable (Const True)), - success "expr eq int" expr "eq($int, 1)" (IntEqualFunc IntVariable (Const 1)), - failure "expr eq type mismatch" expr "eq($bool, 1)", - success "expr list" expr "eq($int, length([]int{1,2}))" (IntEqualFunc IntVariable (IntListLengthFunc [Const 1, Const 2])), + success "expr bool var" (expr mkExpr) "$bool" varBoolExpr, + success "expr bool const" (expr mkExpr) "true" (boolExpr True), + success "expr ==" (expr mkExpr) "== true" (eqExpr varBoolExpr (boolExpr True)), + success "expr *=" (expr mkExpr) "*= \"a\"" (containsStringExpr varStringExpr (stringExpr "a")), + success "expr not" (expr mkExpr) "not(true)" (notExpr (boolExpr True)), + success "expr eq bool" (expr mkExpr) "eq($bool, true)" (eqExpr varBoolExpr (boolExpr True)), + success "expr eq int" (expr mkExpr) "eq($int, 1)" (eqExpr varIntExpr (intExpr 1)), + failure "expr eq type mismatch" (expr mkExpr) "eq($bool, 1)", + success "expr list" (expr mkExpr) "eq($int, length([]int{1,2}))" (eqExpr varIntExpr (lengthListExpr $ intsExpr [intExpr 1, intExpr 2])), - success "name bool" nameExpr "true" (BoolEqualFunc BoolVariable (Const True)), - success "name id" nameExpr "a" (StringEqualFunc StringVariable (Const "a")), - success "name string" nameExpr "\"a\"" (StringEqualFunc StringVariable (Const "a")), - success "name not" nameExpr "!(a)" (NotFunc (StringEqualFunc StringVariable (Const "a"))), - success "name any" nameExpr "_" (Const True), - success "name or" nameExpr "(a|b)" (OrFunc (StringEqualFunc StringVariable (Const "a")) (StringEqualFunc StringVariable (Const "b"))), + success "name bool" nameExpr "true" (eqExpr varBoolExpr (boolExpr True)), + success "name id" nameExpr "a" (eqExpr varStringExpr (stringExpr "a")), + success "name string" nameExpr "\"a\"" (eqExpr varStringExpr (stringExpr "a")), + success "name not" nameExpr "!(a)" (notExpr (eqExpr varStringExpr (stringExpr "a"))), + success "name any" nameExpr "_" (boolExpr True), + success "name or" nameExpr "(a|b)" (orExpr (eqExpr varStringExpr (stringExpr "a")) (eqExpr varStringExpr (stringExpr "b"))), failure "name grouping" nameExpr "((a))", - success "empty" pattern "" Empty, - success "zany" pattern "*" ZAny, - success "or" pattern "(*|*)" (Or ZAny ZAny), - success "or list" pattern "(*|*|*)" (Or ZAny (Or ZAny ZAny)), - success "or list longer" pattern "(*|*|*|*|*)" (Or ZAny (Or (Or (Or ZAny ZAny) ZAny) ZAny)), - success "and" pattern "(*&*)" (And ZAny ZAny), - success "and list" pattern "(*&*&*)" (And ZAny (And ZAny ZAny)), - failure "mix and or" pattern "(*|*&*)", - failure "one item in paren" pattern "(*)", - failure "empty paren" pattern "()", - success "zero or more" pattern "(*)*" (ZeroOrMore ZAny), - success "optional" pattern "(*)?" (Optional ZAny), - success "not" pattern "!(*)" (Not ZAny), - success "reference" pattern "@name" (Reference "name"), - success "concat" pattern "[*,*]" (Concat ZAny ZAny), - failure "single concat" pattern "[*]", - failure "empty concat" pattern "[]", - success "concat list" pattern "[*,*,*]" (Concat (Concat ZAny ZAny) ZAny), - success "interleave" pattern "{*;*}" (Interleave ZAny ZAny), - success "interleave list" pattern "{*;*;*}" (Interleave (Interleave ZAny ZAny) ZAny), - failure "empty interleave" pattern "{}", - failure "single interleave" pattern "{*}", - success "contains" pattern ".*" (Contains ZAny), - success "leaf builtin" pattern "== 1" (Node (IntEqualFunc IntVariable (Const 1)) Empty), - success "leaf function" pattern "->eq($int, 1)" (Node (IntEqualFunc IntVariable (Const 1)) Empty), - success "treenode" pattern "a:*" (Node (StringEqualFunc StringVariable (Const "a")) ZAny), - success "any treenode" pattern "_:*" (Node (Const True) ZAny), - success "treenode no colon" pattern "_[*,*]" (Node (Const True) (Concat ZAny ZAny)), + success "empty" (pattern mkExpr) "" Empty, + success "zany" (pattern mkExpr) "*" ZAny, + success "or" (pattern mkExpr) "(*|*)" (Or ZAny ZAny), + success "or list" (pattern mkExpr) "(*|*|*)" (Or ZAny (Or ZAny ZAny)), + success "or list longer" (pattern mkExpr) "(*|*|*|*|*)" (Or ZAny (Or (Or (Or ZAny ZAny) ZAny) ZAny)), + success "and" (pattern mkExpr) "(*&*)" (And ZAny ZAny), + success "and list" (pattern mkExpr) "(*&*&*)" (And ZAny (And ZAny ZAny)), + failure "mix and or" (pattern mkExpr) "(*|*&*)", + failure "one item in paren" (pattern mkExpr) "(*)", + failure "empty paren" (pattern mkExpr) "()", + success "zero or more" (pattern mkExpr) "(*)*" (ZeroOrMore ZAny), + success "optional" (pattern mkExpr) "(*)?" (Optional ZAny), + success "not" (pattern mkExpr) "!(*)" (Not ZAny), + success "reference" (pattern mkExpr) "@name" (Reference "name"), + success "concat" (pattern mkExpr) "[*,*]" (Concat ZAny ZAny), + failure "single concat" (pattern mkExpr) "[*]", + failure "empty concat" (pattern mkExpr) "[]", + success "concat list" (pattern mkExpr) "[*,*,*]" (Concat (Concat ZAny ZAny) ZAny), + success "interleave" (pattern mkExpr) "{*;*}" (Interleave ZAny ZAny), + success "interleave list" (pattern mkExpr) "{*;*;*}" (Interleave (Interleave ZAny ZAny) ZAny), + failure "empty interleave" (pattern mkExpr) "{}", + failure "single interleave" (pattern mkExpr) "{*}", + success "contains" (pattern mkExpr) ".*" (Contains ZAny), + success "leaf builtin" (pattern mkExpr) "== 1" (Node (eqExpr varIntExpr (intExpr 1)) Empty), + success "leaf function" (pattern mkExpr) "->eq($int, 1)" (Node (eqExpr varIntExpr (intExpr 1)) Empty), + success "treenode" (pattern mkExpr) "a:*" (Node (eqExpr varStringExpr (stringExpr "a")) ZAny), + success "any treenode" (pattern mkExpr) "_:*" (Node (boolExpr True) ZAny), + success "treenode no colon" (pattern mkExpr) "_[*,*]" (Node (boolExpr True) (Concat ZAny ZAny)), - success "treenode with contains" pattern "a:*=\"b\"" ( - Node (StringEqualFunc StringVariable (Const "a")) - $ Node (StringContainsFunc StringVariable (Const "b")) Empty), - success "anynode with contains" pattern "_:*=\"b\"" ( - Node (Const True) - $ Node (StringContainsFunc StringVariable (Const "b")) Empty), - success "contains anynode with contains" pattern "._:*=\"b\"" ( - Contains $ Node (Const True) - $ Node (StringContainsFunc StringVariable (Const "b")) Empty), - success "contains anynode with contains or" pattern "(._:*=\"b\"|*)" ( - Or (Contains $ Node (Const True) $ Node (StringContainsFunc StringVariable (Const "b")) Empty) + success "treenode with contains" (pattern mkExpr) "a:*=\"b\"" ( + Node (eqExpr varStringExpr (stringExpr "a")) + $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty), + success "anynode with contains" (pattern mkExpr) "_:*=\"b\"" ( + Node (boolExpr True) + $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty), + success "contains anynode with contains" (pattern mkExpr) "._:*=\"b\"" ( + Contains $ Node (boolExpr True) + $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty), + success "contains anynode with contains or" (pattern mkExpr) "(._:*=\"b\"|*)" ( + Or (Contains $ Node (boolExpr True) $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty) ZAny ), -- (~=\"^([ \t\r\n\v\f])+$\")* - success "Page195E0AddrE0NameE0" pattern "Person:{Name:*;(Addr:*)?;(Email:*)*}" ( - Node (StringEqualFunc StringVariable (Const "Person")) ( + success "Page195E0AddrE0NameE0" (pattern mkExpr) "Person:{Name:*;(Addr:*)?;(Email:*)*}" ( + Node (eqExpr varStringExpr (stringExpr "Person")) (Interleave (Interleave - (Node (StringEqualFunc StringVariable (Const "Name")) ZAny) - (Optional $ Node (StringEqualFunc StringVariable (Const "Addr")) ZAny) + (Node (eqExpr varStringExpr (stringExpr "Name")) ZAny) + (Optional $ Node (eqExpr varStringExpr (stringExpr "Addr")) ZAny) ) - (ZeroOrMore (Node (StringEqualFunc StringVariable (Const "Email")) ZAny)) + (ZeroOrMore (Node (eqExpr varStringExpr (stringExpr "Email")) ZAny)) ) - ) ), - success "whitespace regex" pattern "(~=\"^([ \t\r\n\v\f])+$\")*" ( - ZeroOrMore $ Node (RegexFunc (Const "^([ \t\r\n\v\f])+$") StringVariable) Empty + success "whitespace regex" (pattern mkExpr) "(~=\"^([ \t\r\n\v\f])+$\")*" ( + ZeroOrMore $ Node (regexExpr (stringExpr "^([ \t\r\n\v\f])+$") varStringExpr) Empty ), - success "Page195E0AddrE0NameE0 with whitespace" pattern "Person:{Name:*;(Addr:*)?;(Email:*)*;(~=\"^([ \t\r\n\v\f])+$\")*}" ( - Node (StringEqualFunc StringVariable (Const "Person")) ( + success "Page195E0AddrE0NameE0 with whitespace" (pattern mkExpr) "Person:{Name:*;(Addr:*)?;(Email:*)*;(~=\"^([ \t\r\n\v\f])+$\")*}" ( + Node (eqExpr varStringExpr (stringExpr "Person")) (Interleave (Interleave (Interleave - (Node (StringEqualFunc StringVariable (Const "Name")) ZAny) - (Optional $ Node (StringEqualFunc StringVariable (Const "Addr")) ZAny) + (Node (eqExpr varStringExpr (stringExpr "Name")) ZAny) + (Optional $ Node (eqExpr varStringExpr (stringExpr "Addr")) ZAny) ) - (ZeroOrMore (Node (StringEqualFunc StringVariable (Const "Email")) ZAny)) + (ZeroOrMore (Node (eqExpr varStringExpr (stringExpr "Email")) ZAny)) ) - (ZeroOrMore $ Node (RegexFunc (Const "^([ \t\r\n\v\f])+$") StringVariable) Empty) + (ZeroOrMore $ Node (regexExpr (stringExpr "^([ \t\r\n\v\f])+$") varStringExpr) Empty) ) - ) ), - success "single pattern grammar" grammar "*" $ newRef "main" ZAny, - success "single pattern decl" grammar "#main = *" $ newRef "main" ZAny, - failure "two patterns grammar" grammar "* *", - success "two pattern decls" grammar "#main = * #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny, - success "one pattern and one pattern decl" grammar "* #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny, - success "one pattern and two pattern decls" grammar "* #a = * #b = *" $ newRef "main" ZAny `union` newRef "a" ZAny `union` newRef "b" ZAny, + success "single pattern grammar" (grammar mkExpr) "*" $ newRef "main" ZAny, + success "single pattern decl" (grammar mkExpr) "#main = *" $ newRef "main" ZAny, + failure "two patterns grammar" (grammar mkExpr) "* *", + success "two pattern decls" (grammar mkExpr) "#main = * #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny, + success "one pattern and one pattern decl" (grammar mkExpr) "* #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny, + success "one pattern and two pattern decls" (grammar mkExpr) "* #a = * #b = *" $ newRef "main" ZAny `union` newRef "a" ZAny `union` newRef "b" ZAny, - success "not pattern, not name and != conflicts without not enough lookahead" grammar "!(A):*" (newRef "main" (Node (NotFunc (StringEqualFunc StringVariable (Const "A"))) ZAny)), - success "->type conflicts with ->true and -1 conflicts with ->" grammar "->type($string)" (newRef "main" (Node (StringTypeFunc StringVariable) Empty)), - success "<= conflicts with " grammar "<= 0" (newRef "main" (Node (IntLessOrEqualFunc IntVariable (Const 0)) Empty)), - success "unexpected space builtin treenode child" grammar "A == \"F\"" (newRef "main" (Node (StringEqualFunc StringVariable (Const "A")) (Node (StringEqualFunc StringVariable (Const "F")) Empty))), - success "unexpected space after comment" grammar "(* & */*spaces*/ )" (newRef "main" (And ZAny ZAny)), - success "treenode with child builtin type" grammar "A :: $string" (newRef "main" (Node (StringEqualFunc StringVariable (Const "A")) (Node (StringTypeFunc StringVariable) Empty))), - success "extra semicolon" grammar "{*;*;}" (newRef "main" (Interleave ZAny ZAny)), + success "not pattern, not name and != conflicts without not enough lookahead" (grammar mkExpr) "!(A):*" (newRef "main" (Node (notExpr (eqExpr varStringExpr (stringExpr "A"))) ZAny)), + success "->type conflicts with ->true and -1 conflicts with ->" (grammar mkExpr) "->type($string)" (newRef "main" (Node (typeExpr varStringExpr) Empty)), + success "<= conflicts with " (grammar mkExpr) "<= 0" (newRef "main" (Node (leExpr varIntExpr (intExpr 0)) Empty)), + success "unexpected space builtin treenode child" (grammar mkExpr) "A == \"F\"" (newRef "main" (Node (eqExpr varStringExpr (stringExpr "A")) (Node (eqExpr varStringExpr (stringExpr "F")) Empty))), + success "unexpected space after comment" (grammar mkExpr) "(* & */*spaces*/ )" (newRef "main" (And ZAny ZAny)), + success "treenode with child builtin type" (grammar mkExpr) "A :: $string" (newRef "main" (Node (eqExpr varStringExpr (stringExpr "A")) (Node (typeExpr varStringExpr) Empty))), + success "extra semicolon" (grammar mkExpr) "{*;*;}" (newRef "main" (Interleave ZAny ZAny)), + success "user defined function" (grammar bothLibs) "->isPrime($int)" (newRef "main" (Node (isPrimeExpr varIntExpr) Empty)), + failure "user defined function" (grammar mkExpr) "->isPrime($int)", + HUnit.testCase "" (return ())] + +bothLibs :: String -> [AnyExpr] -> Either String AnyExpr +bothLibs name args = case mkExpr name args of + (Left err) -> userLib name args + (Right expr) -> return expr diff --git a/test/RelapseSpec.hs b/test/RelapseSpec.hs --- a/test/RelapseSpec.hs +++ b/test/RelapseSpec.hs @@ -7,34 +7,44 @@ import qualified Test.Tasty as T import qualified Test.Tasty.HUnit as HUnit -import Control.Monad.Except (runExcept) - import Relapse import Json +import UserDefinedFuncs +import Expr (AnyExpr) +import Exprs (mkExpr) tests = T.testGroup "Relapse" [ HUnit.testCase "parseGrammar success" $ either HUnit.assertFailure (\_ -> return ()) $ - runExcept $ Relapse.parseGrammar "a == 1" + Relapse.parse "a == 1" , HUnit.testCase "parseGrammar failure" $ either (\_ -> return ()) (\_ -> HUnit.assertFailure "expected error") $ - runExcept $ Relapse.parseGrammar "{ a : 1 }" + Relapse.parse "{ a : 1 }" , HUnit.testCase "validate success" $ either HUnit.assertFailure (HUnit.assertBool "expected success") $ Relapse.validate <$> - runExcept (Relapse.parseGrammar "a == 1") <*> + Relapse.parse "a == 1" <*> Json.decodeJSON "{\"a\":1}" , HUnit.testCase "validate failure" $ either HUnit.assertFailure (HUnit.assertBool "expected failure" . not) $ Relapse.validate <$> - runExcept (Relapse.parseGrammar "a == 1") <*> + Relapse.parse "a == 1" <*> Json.decodeJSON "{\"a\":2}" , HUnit.testCase "filter" $ case do { - refs <- runExcept $ Relapse.parseGrammar "a == 1"; + refs <- Relapse.parse "a == 1"; want <- Json.decodeJSON "{\"a\":1}"; other <- Json.decodeJSON "{\"a\":2}"; + return (Relapse.filter refs [want, other], [want]); + } of + (Left err) -> HUnit.assertFailure err + (Right (got, want)) -> HUnit.assertEqual "expected the same tree" want got + + , HUnit.testCase "user defined function" $ case do { + refs <- Relapse.parseWithUDFs userLib "a->isPrime($int)"; + want <- Json.decodeJSON "{\"a\":3}"; + other <- Json.decodeJSON "{\"a\":4}"; return (Relapse.filter refs [want, other], [want]); } of (Left err) -> HUnit.assertFailure err diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,6 +10,7 @@ import qualified ParserSpec import qualified Suite import qualified RelapseSpec +import qualified DeriveSpec main :: IO () main = do { @@ -18,5 +19,6 @@ ParserSpec.tests , RelapseSpec.tests , Suite.tests testSuiteCases + , DeriveSpec.tests ] } diff --git a/test/Suite.hs b/test/Suite.hs --- a/test/Suite.hs +++ b/test/Suite.hs @@ -10,10 +10,10 @@ import System.Directory (getCurrentDirectory, listDirectory, doesDirectoryExist) import System.FilePath (FilePath, (), takeExtension, takeBaseName, takeDirectory) import Text.XML.HXT.DOM.TypeDefs (XmlTree) -import Control.Monad.Except (Except(..), runExcept) import Parsers (Tree) -import Patterns (Refs, Pattern, nullable, hasRecursion) +import Smart (Grammar, Pattern, nullable, compile) +import qualified Ast import Json (JsonTree, decodeJSON) import Xml (decodeXML) import Parser (parseGrammar) @@ -24,7 +24,7 @@ tests :: [TestSuiteCase] -> T.TestTree tests testSuiteCases = - let nonRecursiveTestCases = filter (\(TestSuiteCase _ g _ _) -> not (hasRecursion g)) testSuiteCases + let nonRecursiveTestCases = filter (\(TestSuiteCase _ g _ _) -> not (either error id $ Ast.hasRecursion g)) testSuiteCases derivTests = T.testGroup "derive" $ map (newTestCase AlgoDeriv) nonRecursiveTestCases zipTests = T.testGroup "zip" $ map (newTestCase AlgoZip) nonRecursiveTestCases mapTests = T.testGroup "map" $ map (newTestCase AlgoMap) nonRecursiveTestCases @@ -47,7 +47,7 @@ data TestSuiteCase = TestSuiteCase { name :: String - , grammar :: Refs + , grammar :: Ast.Grammar , input :: EncodedData , valid :: Bool } deriving Show @@ -72,28 +72,35 @@ testName :: Algo -> TestSuiteCase -> String testName algo (TestSuiteCase name g t want) = name ++ "_" ++ show algo -must :: Except String Pattern -> Pattern -must e = case runExcept e of - (Left l) -> error l - (Right r) -> r - -testDeriv :: Tree t => Algo -> String -> Refs -> [t] -> Bool -> IO () +testDeriv :: Tree t => Algo -> String -> Ast.Grammar -> [t] -> Bool -> IO () testDeriv AlgoDeriv name g ts want = - let p = must $ Derive.derive g ts - got = nullable g p - in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do { + compiled <- compile g; + Derive.derive compiled ts; + }) + got = nullable p + in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got testDeriv AlgoZip name g ts want = - let p = must $ Derive.zipderive g ts - got = nullable g p - in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do { + compiled <- compile g; + Derive.zipderive compiled ts; + }) + got = nullable p + in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got testDeriv AlgoMap name g ts want = - let p = must $ MemDerive.derive g ts - got = nullable g p - in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do { + compiled <- compile g; + MemDerive.derive compiled ts; + }) + got = nullable p + in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got testDeriv AlgoVpa name g ts want = - let p = must $ VpaDerive.derive g ts - got = nullable g p - in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do { + compiled <- compile g; + VpaDerive.derive compiled ts; + }) + got = nullable p + in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got getRelapseJson :: [FilePath] -> FilePath getRelapseJson paths = head $ filter (\fname -> takeExtension fname == ".json" && takeBaseName fname == "relapse") paths @@ -107,10 +114,10 @@ filepathWithExt :: [FilePath] -> String -> FilePath filepathWithExt paths ext = head $ filter (\fname -> takeExtension fname == ext && takeBaseName fname /= "relapse") paths -fromGrammar :: String -> Refs +fromGrammar :: String -> Ast.Grammar fromGrammar s = case parseGrammar s of (Left err) -> error $ "given input: <" ++ s ++ "> got parse error: " ++ show err - (Right r) -> r + (Right g) -> g readJsonTest :: FilePath -> IO TestSuiteCase readJsonTest path = do { diff --git a/test/UserDefinedFuncs.hs b/test/UserDefinedFuncs.hs new file mode 100644 --- /dev/null +++ b/test/UserDefinedFuncs.hs @@ -0,0 +1,79 @@ +module UserDefinedFuncs ( + userLib + , incExpr + , concatExpr + , isPrimeExpr +) where + +import qualified Data.Text + +import Data.Numbers.Primes (isPrime) + +import Expr + +-- | +-- userLib is a library of user defined functions that can be passed to the parser. +userLib :: String -> [AnyExpr] -> Either String AnyExpr +userLib "inc" args = mkIncExpr args +userLib "concat" args = mkConcatExpr args +userLib "isPrime" args = mkIsPrime args +userLib n _ = Left $ "undefined function: " ++ n + +-- | +-- mkIncExpr tries to create an incExpr from a variable number and dynamically types arguments. +-- This function is used by the Relapse parser to insert your user defined expression into the expression tree. +mkIncExpr :: [AnyExpr] -> Either String AnyExpr +mkIncExpr args = do { + arg <- assertArgs1 "inc" args; + mkIntExpr . incExpr <$> assertInt arg; +} + +-- | +-- incExpr creates an expression that increases its input argument by 1. +-- This function is also useful if we want to build up our own well typed expression tree, +-- bypassing the Relapse parser. +incExpr :: Expr Int -> Expr Int +incExpr intArg = trimInt Expr { + desc = mkDesc "inc" [desc intArg] + , eval = \fieldValue -> (+1) <$> eval intArg fieldValue +} + +-- | +-- mkConcatExpr tries to create an concatExpr from a variable number and dynamically types arguments. +mkConcatExpr :: [AnyExpr] -> Either String AnyExpr +mkConcatExpr args = do { + (arg1, arg2) <- assertArgs2 "inc" args; + strArg1 <- assertString arg1; + strArg2 <- assertString arg2; + return $ mkStringExpr $ concatExpr strArg1 strArg2; +} + +-- | +-- concatExpr creates an expression that concatenates two string together. +concatExpr :: Expr Data.Text.Text -> Expr Data.Text.Text -> Expr Data.Text.Text +concatExpr strExpr1 strExpr2 = trimString Expr { + desc = mkDesc "concat" [desc strExpr1, desc strExpr2] + , eval = \fieldValue -> do { + str1 <- eval strExpr1 fieldValue; + str2 <- eval strExpr2 fieldValue; + return $ Data.Text.concat [str1,str2]; + } +} + +-- | +-- mkIsPrimeExpr tries to create an isPrimeExpr from a variable number and dynamically types arguments. +mkIsPrime :: [AnyExpr] -> Either String AnyExpr +mkIsPrime args = do { + arg <- assertArgs1 "isPrime" args; + case arg of + (AnyExpr _ (IntFunc _)) -> mkBoolExpr . isPrimeExpr <$> assertInt arg; + (AnyExpr _ (UintFunc _)) -> mkBoolExpr . isPrimeExpr <$> assertUint arg; +} + +-- | +-- isPrime creates an expression checks whether a number is prime. +isPrimeExpr :: Integral a => Expr a -> Expr Bool +isPrimeExpr numExpr = trimBool Expr { + desc = mkDesc "isPrime" [desc numExpr] + , eval = \fieldValue -> isPrime <$> eval numExpr fieldValue +}